Basic version of 'downloadURL'

This commit is contained in:
Julian Ospald 2020-01-16 23:27:38 +01:00
parent 3fb5c612c1
commit 92531045f8
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
12 changed files with 355 additions and 238 deletions

View File

@ -1 +1,34 @@
# ghcup
A rewrite of ghcup in haskell. This can be used as a library
and may be redistributed as a binary in the future.
## Motivation
ghcup has increasingly become difficult to maintain. A few reasons:
* few maintainers
* increasing LOC
* platform incompatibilities regularly causing breaking bugs:
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
* refactoring being difficult due to POSIX sh
More benefits of a rewrite:
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
* Refactoring will be easier
* Better tool support (such as linting the downloads file)
* saner downloads file format (such as JSON)
However, the downside will be:
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
* still bootstrapping those binaries via a POSIX sh script
## Goals
* Correct low-level code
* Good exception handling
* Easier user interface (possibly interactive and non-interactive ones)

12
TODO.md Normal file
View File

@ -0,0 +1,12 @@
# TODOs and Remarks
* handling of SIGTERM and SIGUSR
* add support for RC/alpha/HEAD versions
* redo/rethink how tool tags works
* installing multiple versions in parallel?
* exception handling (checked exception library? Maybe effects system all the way?)
* how to version and extend the format of the downloads file? Compatibility?
* how to propagate updates? Automatically? Might solve the versioning problem

View File

@ -1,2 +1,9 @@
packages: ./ghcup.cabal
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

View File

@ -20,6 +20,7 @@ source-repository head
type: git
location: https://github.com/hasufell/ghcup-hs
common aeson { build-depends: aeson >= 1.4 }
common ascii-string { build-depends: ascii-string >= 1.0 }
common base { build-depends: base >= 4.12.0.0 && < 5 }
common bytestring { build-depends: bytestring >= 0.10 }
@ -36,12 +37,16 @@ common streamly { build-depends: streamly >= 0.7 }
common strict-base { build-depends: strict-base >= 0.4 }
common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 }
common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 }
common url { build-depends: url >= 2.1 }
common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common async { build-depends: async >= 0.8 }
common mtl { build-depends: mtl >= 2.2 }
common versions { build-depends: versions >= 3.5 }
common config
@ -53,7 +58,9 @@ library
import: config
, base
-- deps
, aeson
, ascii-string
, async
, bytestring
, containers
, generics-sop
@ -61,6 +68,7 @@ library
, hpath-filepath
, hpath-io
, language-bash
, mtl
, optics
, parsec
, safe-exceptions
@ -68,12 +76,13 @@ library
, strict-base
, template-haskell
, text
, text-icu
, transformers
, unix
, url
, utf8-string
, vector
, waargonaut
, versions
exposed-modules: GHCup
GHCup.Bash
GHCup.File

View File

@ -10,44 +10,46 @@
-- TODO: handle SIGTERM, SIGUSR
module GHCup where
import Control.Applicative
import Data.Strict.Maybe
import Data.Version
import GHCup.Prelude
import Control.Monad
import Data.Foldable ( asum )
import Data.Text ( Text )
import Data.Versions
import GHCup.Bash
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import GHCup.Types.Optics
import HPath
import HPath.IO
import Network.URL
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Optics
import Prelude hiding ( abs
, Maybe
, Just
, Nothing
, readFile
)
import System.Info
import qualified Data.Text as T
import qualified Data.Text.ICU as ICU
import Data.Maybe ( isJust )
import qualified Data.Map.Strict as Map
import qualified GHC.Exts as GE
import qualified Prelude as P
import qualified System.Posix.Process.ByteString
as SPPB
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
[ ( mkV [8, 6, 5]
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
, Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
, Map.fromList
[ ( Nothing
, mkGHCUrl
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
)
]
)
]
)
@ -57,101 +59,170 @@ availableDownloads = Map.fromList
)
]
where
mkV = makeVersion
mkGHCUrl path = URL
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
, url_path = path
, url_params = []
}
downloadURL :: Tool
downloadURL :: ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> IO (Maybe URL) -- TODO: better error handling
downloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
(PlatformResult rp rv) <- getPlatform
let ar = (\(Right x) -> x) getArchitecture
pure $ PlatformRequest ar rp rv
dls <- case urlSource of
GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
pure $ downloadURL' t v arch plat ver dls
downloadURL' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Maybe URL
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro
downloadURL' t v a p mv dls =
with_distro <|> without_distro_ver <|> without_distro
where
with_distro = distro_preview id
without_distro = distro_preview withoutDistro
without_ver = distro_preview withoutVer
with_distro = distro_preview id id
without_distro = distro_preview (set _Linux UnknownLinux) id
without_distro_ver = distro_preview id (const Nothing)
distro_preview f =
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls
distro_preview f g =
preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
atJust x = at x % _Just
-- | If we can't find a version with the given distro,
-- then just try with the platform.
withoutDistro :: Platform -> Platform
withoutDistro (Linux _) = Linux UnknownLinux
withoutDistro Darwin = Darwin
withoutDistro (FreeBSD _) = FreeBSD Nothing
-- | If we can't find a match with the given distro version,
-- we gotta try without it.
withoutVer :: Platform -> Platform
withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing
withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing
withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing
withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing
withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux
withoutVer Darwin = Darwin
withoutVer (FreeBSD _) = FreeBSD Nothing
getArchitecture :: IO Architecture
getArchitecture :: Either String Architecture
getArchitecture = case arch of
"x86_64" -> pure A_64
"i386" -> pure A_32
what -> fail ("Could not find compatible architecture. Was: " <> what)
what -> Left ("Could not find compatible architecture. Was: " <> what)
getPlatform :: IO Platform
getPlatform :: IO PlatformResult
getPlatform = case os of
"linux" -> do
distro <- getLinuxDistro
pure $ Linux distro
(distro, ver) <- getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified
"darwin" -> pure $ Darwin
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ FreeBSD ver
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> fail ("Could not find compatible platform. Was: " <> what)
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: IO (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
(name, ver) <- asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
| hasWord name (T.pack <$> ["debian"]) -> Debian
| hasWord name (T.pack <$> ["ubuntu"]) -> Ubuntu
| hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
| hasWord name (T.pack <$> ["fedora"]) -> Fedora
| hasWord name (T.pack <$> ["centos"]) -> CentOS
| hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
| hasWord name (T.pack <$> ["alpine"]) -> Alpine
| hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
| hasWord name (T.pack <$> ["gentoo"]) -> Gentoo
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
getLinuxDistro :: IO LinuxDistro
getLinuxDistro = do
let os_release = [abs|/etc/os-release|]
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
$ t
)
|| y
)
False
matches
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Fn
lsb_release_cmd = [fn|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
pure undefined
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
getFreeBSDVersion = pure Nothing
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd
(Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
ver <- executeOut lsb_release_cmd [fS "-sr"]
pure (lBS2sT name, fmap (lBS2sT . fst) ver)
-- Try various methods for getting distro name and version.
-- Failure is signalled with an IO exception.
try_os_release :: IO (String, P.Maybe String)
try_os_release = do
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case
P.Just s -> pure $ s
P.Nothing -> fail "No value found"
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID"
pure (name, version)
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap lBS2sT $ readFile redhat_release
let nameRe n =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b")
)
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b"))
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (name, verRe)
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
True <- doesFileExist debian_version
ver <- readFile debian_version
pure (T.pack "debian", Just $ lBS2sT ver)
try_lsb_release_cmd :: IO (String, P.Maybe String)
try_lsb_release_cmd = findExecutable ([fn|lsb_release|] :: Path Fn) >>= \case
P.Nothing -> fail "lsb_release not found"
P.Just path -> do
name <- executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] >>= \case
P.Just (out, _) -> pure out
_ -> fail "Barfed output of lsb_release"
version <- (fmap . fmap) (UTF8.toString . fst)
$ executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"]
pure (UTF8.toString name, version)

View File

@ -1,58 +1,47 @@
module GHCup.Bash where
module GHCup.Bash
( findAssignment
, equalsAssignmentWith
, getRValue
, getAssignmentValueFor
)
where
import Data.ByteString
import Language.Bash.Parse.Word
import Language.Bash.Parse
import Language.Bash.Word
import Language.Bash.Syntax
import Text.Parsec
import HPath
import HPath.IO
import Data.ByteString.UTF8 ( toString )
import Streamly
import GHCup.File
import GHCup.Prelude ( internalError )
import qualified Streamly.Prelude as S
import Control.Monad
import Data.Maybe
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Prelude hiding ( readFile )
import Data.List
-- | Parse a single assignment of the given line.
parseAssignment :: SourceName -- ^ file/location of the parser
-> ByteString -- ^ the line as a bytestring
-> Either ParseError Assign
parseAssignment = runParser assign ()
extractAssignments :: List -> [Assign]
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
where
getCommands :: [Statement] -> [Command]
getCommands = join . fmap commands . catMaybes . fmap findPipes
where
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
findPipes _ = Nothing
-- | Parse assignments in a stream.
parseAssignments :: Monad m
=> SourceName -- ^ file/location of the parser
-> SerialT m (ByteString)
-> SerialT m (Either ParseError Assign)
parseAssignments sn = fmap (parseAssignment sn)
getAssign :: Command -> [Assign]
getAssign (Command (SimpleCommand ass _) _) = ass
getAssign _ = []
-- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b
-> (Assign -> Bool) -- ^ predicate
-> IO (Maybe Assign)
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
findAssignment p predicate = do
let fn' = toString . toFilePath $ p
stream <- fmap (parseAssignments fn') $ readFileLines p
res <-
S.find -- empties the stream on first match, but doesn't terminate it
(\case
Right ass -> predicate ass
Left _ -> False
)
stream
>>= \case
Just (Right x) -> pure (Just x)
Just (Left _) ->
internalError "unexpected Left in findAssignment"
Nothing -> pure Nothing
-- Closes the file handle. Because if there was a match, then
-- the stream is not terminated.
when (isJust res) $ S.drain stream
pure res
fileContents <- readFile p
-- TODO: this should accept bytestring:
-- https://github.com/knrafto/language-bash/issues/37
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
Left e -> fail $ show e
Right l -> pure $ find predicate (extractAssignments $ l)
-- | Check that the assignment is of the form Foo= ignoring the

View File

@ -1,6 +1,6 @@
module GHCup.File where
import Data.ByteString hiding (putStrLn)
import Data.ByteString
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Maybe
@ -14,7 +14,9 @@ import Control.Monad
import Control.Exception.Safe
import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.IO.ByteString hiding (openFd)
import System.IO
import System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Types
@ -24,19 +26,11 @@ import qualified Streamly.Internal.Memory.ArrayStream
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import System.IO
import System.Exit
import qualified Streamly.Data.Fold as FL
import Data.ByteString.Builder
import Foreign.C.Error
import GHCup.Prelude
import Control.Monad.Trans.Maybe
import HPath.Internal
import System.Posix.FD
(
openFd
)
-- |Checks whether a file is executable. Follows symlinks.
@ -66,20 +60,12 @@ readFd fd = do
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream' p
stream <- readFileStream p
pure
. (>>= arrayToByteString)
. AS.splitOn (fromIntegral $ ord '\n')
. (>>= byteStringToArray)
$ stream
where
readFileStream' :: Path b
-> IO (SerialT IO ByteString)
readFileStream' (MkPath fp) = do
fd <- openFd fp ReadOnly [] Nothing
handle' <- fdToHandle fd
let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString
pure stream
-- | Find the given executable by searching all *absolute* PATH components.
@ -92,42 +78,32 @@ findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
sPaths
findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs))
findExecutablee ex = do
sPaths <- mapMaybe parseAbs <$> getSearchPath
runMaybeT $ asum (MaybeT . eExists <$> sPaths)
where
eExists sp = let path = sp </> ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path
-- TODO: fd leak
-- | Execute the given command and collect the stdout and the exit code.
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
executeOut path args = withFnPath path $ \fp -> do
(readE, writeE) <- createPipe
(parentRead, childWrite) <- createPipe
pid <- SPPB.forkProcess $ do
whileM_
(dupTo writeE stdOutput)
(dupTo childWrite stdOutput)
(\r ->
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
)
closeFd writeE
closeFd readE
closeFd childWrite
closeFd parentRead
closeFd stdInput
SPPB.executeFile fp True args Nothing
closeFd writeE
closeFd childWrite
-- readFd will take care of closing the fd
SPPB.getProcessStatus True True pid >>= \case
Just (SPPB.Exited es) -> do
out <- readFd readE
pure $ Just (out, es)
_ -> pure Nothing
-- readE will take care of closing the fd
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
_ -> closeFd parentRead $> Nothing

View File

@ -5,16 +5,21 @@
module GHCup.Prelude where
import Control.Applicative
import Control.Monad
import Data.Strict.Maybe
import Data.Monoid ( (<>) )
import Prelude ( Monad
, Bool
, return
, (.)
, (>>=)
)
import qualified Prelude as P
import Data.String
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import Data.Text ( Text )
import qualified Data.ByteString.Lazy as L
fS :: IsString a => P.String -> a
@ -23,9 +28,15 @@ fS = fromString
fromStrictMaybe :: Maybe a -> P.Maybe a
fromStrictMaybe = maybe P.Nothing P.Just
fSM :: Maybe a -> P.Maybe a
fSM = fromStrictMaybe
toStrictMaybe :: P.Maybe a -> Maybe a
toStrictMaybe = P.maybe Nothing Just
tSM :: P.Maybe a -> Maybe a
tSM = toStrictMaybe
instance Applicative Maybe where
pure = Just
@ -61,6 +72,17 @@ ifM ~b ~t ~f = do
b' <- b
if b' then t else f
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ action f = whenM (action >>= f) (whileM_ action f)
whileM :: Monad m => m a -> (a -> m Bool) -> m a
whileM ~action ~f = do
a <- action
b' <- f a
if b' then whileM action f else pure a
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ ~action = void . whileM action
guardM :: (Monad m, Alternative m) => m Bool -> m ()
guardM f = guard =<< f
lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8

View File

@ -2,50 +2,66 @@
module GHCup.Types where
import Data.Map.Strict (Map)
import Data.Strict.Maybe
import Data.Text
import Data.Version
import Data.Map.Strict ( Map )
import Network.URL
import Prelude hiding (
Maybe
, Just
, Nothing)
import qualified GHC.Generics as GHC
import Data.Versions
-- | Requested tool to be installed. User input.
data Tool = GHC
| Cabal
| Stack
deriving (Eq, Ord, Show)
-- | Architecture we run on.
data ToolRequest = ToolRequest {
_tool :: Tool
, _toolVersion :: Version
} deriving (Eq, Show)
data Architecture = A_64
| A_32
deriving (Eq, Ord, Show)
data LinuxDistro = Debian (Maybe CustomVersion)
| Ubuntu (Maybe CustomVersion)
| Mint (Maybe CustomVersion)
| Fedora (Maybe CustomVersion)
data LinuxDistro = Debian
| Ubuntu
| Mint
| Fedora
| CentOS
| RedHat
| Alpine
-- rolling
| Gentoo
| Exherbo
-- not known
| UnknownLinux
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
data Platform = Linux LinuxDistro
-- ^ must exit
| Darwin
-- ^ must exit
| FreeBSD (Maybe CustomVersion)
| FreeBSD
deriving (Eq, GHC.Generic, Ord, Show)
type CustomVersion = Text
type PlatformSpec = Map Platform URL
type ArchitectureSpec = Map Architecture PlatformSpec
type VersionSpec = Map Version ArchitectureSpec
type AvailableDownloads = Map Tool VersionSpec
data PlatformResult = PlatformResult {
_platform :: Platform
, _distroVersion :: Maybe Versioning
} deriving (Eq, Show)
data PlatformRequest = PlatformRequest {
_rArch :: Architecture
, _rPlatform :: Platform
, _rVersion :: Maybe Versioning
} deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) URL
type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version ArchitectureSpec
type AvailableDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL
| OwnSource URL
| OwnSpec AvailableDownloads

View File

@ -1,18 +0,0 @@
encToJsonNoSpaces
:: ( Monoid t
, Applicative f
)
=> AReview Json (b, t)
-> (a -> b)
-> Encoder f a
encToJsonNoSpaces c f =
encodeA (pure . review c . (, mempty) . f)
bytestring :: Applicative f => Encoder f ByteString
bytestring = encToJsonNoSpaces _JStr (_JStringBS #)
_JStringBS :: (Profunctor p, Applicative f)
=> p ByteString (f ByteString)
-> p JString (f JString)
_JStringBS = iso (C.pack . review _JString)
(JString' . V.fromList . fmap utf8CharToJChar . C.unpack)

View File

@ -11,30 +11,19 @@ module GHCup.Types.JSON where
import Data.Strict.Maybe
import GHCup.Types
import Generics.SOP.TH
import Prelude hiding (
Maybe
, Just
, Nothing)
import Waargonaut.Generic (
JsonEncode
, JsonDecode
, GWaarg)
import Prelude hiding ( Maybe )
import Data.Versions
import Data.Aeson
import Data.Aeson.TH
deriveGeneric ''Maybe
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a)
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a)
deriveGeneric ''Tool
instance JsonEncode GWaarg Tool
instance JsonDecode GWaarg Tool
deriveGeneric ''Architecture
instance JsonEncode GWaarg Architecture
instance JsonDecode GWaarg Architecture
deriveGeneric ''LinuxDistro
instance JsonEncode GWaarg LinuxDistro
instance JsonDecode GWaarg LinuxDistro
deriveJSON defaultOptions ''Architecture
deriveJSON defaultOptions ''LinuxDistro
deriveJSON defaultOptions ''Maybe
deriveJSON defaultOptions ''Mess
deriveJSON defaultOptions ''SemVer
deriveJSON defaultOptions ''Tool
deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''Version
deriveJSON defaultOptions ''Versioning

View File

@ -2,4 +2,15 @@
module GHCup.Types.Optics where
import GHCup.Types
import Optics
makePrisms ''Tool
makePrisms ''Architecture
makePrisms ''LinuxDistro
makePrisms ''Platform
makeLenses ''PlatformResult
makeLenses ''ToolRequest