hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Yeah

This commit is contained in:
Julian Ospald 2020-02-19 20:54:23 +01:00
parent 57cf985e05
commit 21917dea3e
7 changed files with 132 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project.freeze
View File

@ -142,7 +142,7 @@ constraints: any.Cabal ==2.4.0.1,
any.syb ==0.7.1, any.syb ==0.7.1,
any.tagged ==0.8.6, any.tagged ==0.8.6,
tagged +deepseq +transformers, tagged +deepseq +transformers,
any.tar-bytestring ==0.6.1.3, any.tar-bytestring ==0.6.2.0,
any.template-haskell ==2.14.0.0, any.template-haskell ==2.14.0.0,
any.terminfo ==0.4.1.2, any.terminfo ==0.4.1.2,
any.text ==1.2.3.1, any.text ==1.2.3.1,

12
ghcup.cabal
View File

@ -40,23 +40,26 @@ common language-bash { build-depends: language-bash >= 0.9 }
common lzma { build-depends: lzma >= 0.0.0.3 } common lzma { build-depends: lzma >= 0.0.0.3 }
common mtl { build-depends: mtl >= 2.2 } common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 } common optics { build-depends: optics >= 0.2 }
common optics-vl { build-depends: optics-vl >= 0.2 }
common parsec { build-depends: parsec >= 3.1 } common parsec { build-depends: parsec >= 3.1 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } common streamly { build-depends: streamly >= 0.7 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 } common strict-base { build-depends: strict-base >= 0.4 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.1.3 } common string-qq { build-depends: string-qq >= 0.0.4 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 } common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 } common text-icu { build-depends: text-icu >= 0.7 }
common transformers { build-depends: transformers >= 0.5 } common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 } common unix { build-depends: unix >= 2.7 }
common unix-bytestring { build-depends: unix-bytestring >= 0.3 } common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
common url { build-depends: url >= 2.1 } common uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
common utf8-string { build-depends: utf8-string >= 1.0 } common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 } common vector { build-depends: vector >= 0.12 }
common versions { build-depends: versions >= 3.5 } common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 } common waargonaut { build-depends: waargonaut >= 0.8 }
common word8 { build-depends: word8 >= 0.1.3 }
common zlib { build-depends: zlib >= 0.6.2.1 } common zlib { build-depends: zlib >= 0.6.2.1 }
@ -95,11 +98,13 @@ library
, lzma , lzma
, mtl , mtl
, optics , optics
, optics-vl
, parsec , parsec
, safe-exceptions , safe-exceptions
, streamly , streamly
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-qq
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
, text , text
@ -107,10 +112,11 @@ library
, transformers , transformers
, unix , unix
, unix-bytestring , unix-bytestring
, url , uri-bytestring
, utf8-string , utf8-string
, vector , vector
, versions , versions
, word8
, zlib , zlib
exposed-modules: GHCup exposed-modules: GHCup
GHCup.Bash GHCup.Bash

142
lib/GHCup.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-}
-- TODO: handle SIGTERM, SIGUSR -- TODO: handle SIGTERM, SIGUSR
module GHCup where module GHCup where
@ -19,6 +19,7 @@ import Control.Monad.IO.Class
import Control.Exception.Safe import Control.Exception.Safe
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Foldable ( asum ) import Data.Foldable ( asum )
import Data.String.QQ
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import GHCup.Bash import GHCup.Bash
@ -28,7 +29,6 @@ import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import HPath import HPath
import HPath.IO import HPath.IO
import Network.URL
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, readFile , readFile
@ -36,10 +36,11 @@ import Prelude hiding ( abs
import System.Info import System.Info
import System.IO.Error import System.IO.Error
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU import qualified Data.Text.ICU as ICU
import Data.Maybe import Data.Maybe
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
import GHC.IO.Handle import GHC.IO.Handle
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
@ -75,7 +76,10 @@ import qualified Codec.Compression.BZip as BZip
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.Process.ByteString import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import System.Posix.Directory.ByteString (changeWorkingDirectory) import System.Posix.Directory.ByteString
( changeWorkingDirectory )
import URI.ByteString
import URI.ByteString.QQ
@ -100,6 +104,9 @@ data DistroNotFound = DistroNotFound
data ArchiveError = UnknownArchive ByteString data ArchiveError = UnknownArchive ByteString
deriving Show deriving Show
data URLException = UnsupportedURL
deriving Show
---------------------- ----------------------
@ -107,32 +114,29 @@ data ArchiveError = UnknownArchive ByteString
---------------------- ----------------------
-- TODO: version quasiquoter
availableDownloads :: AvailableDownloads availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList availableDownloads = Map.fromList
[ ( GHC [ ( GHC
, Map.fromList , Map.fromList
[ ( (\(Right x) -> x) $ version (fS "8.6.5") [ ( (\(Right x) -> x) $ version [s|8.6.5|]
, Map.fromList , Map.fromList
[ ( A_64 [ ( A_64
, Map.fromList , Map.fromList
[ ( Linux UnknownLinux [ ( Linux UnknownLinux
, Map.fromList , Map.fromList
[ ( Nothing [ ( Nothing
, mkGHCUrl , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
) )
] ]
) )
, ( Linux Debian , ( Linux Debian
, Map.fromList , Map.fromList
[ ( Nothing [ ( Nothing
, mkGHCUrl , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz"
) )
, ( Just $ (\(Right x) -> x) $ versioning (fS "8") , ( Just $ (\(Right x) -> x) $ versioning [s|8|]
, mkGHCUrl , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz"
) )
] ]
) )
@ -143,12 +147,7 @@ availableDownloads = Map.fromList
] ]
) )
] ]
where
mkGHCUrl path = URL
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
, url_path = path
, url_params = []
}
getDownloadURL :: (MonadCatch m, MonadIO m) getDownloadURL :: (MonadCatch m, MonadIO m)
@ -158,7 +157,7 @@ getDownloadURL :: (MonadCatch m, MonadIO m)
-> Excepts -> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m m
URL URI
getDownloadURL (ToolRequest t v) mpfReq urlSource = do getDownloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of (PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x Just x -> pure x
@ -185,7 +184,7 @@ getDownloadURL' :: Tool
-> Maybe Versioning -> Maybe Versioning
-- ^ optional version of the platform -- ^ optional version of the platform
-> AvailableDownloads -> AvailableDownloads
-> Either NoDownload URL -> Either NoDownload URI
getDownloadURL' t v a p mv dls = maybe getDownloadURL' t v a p mv dls = maybe
(Left NoDownload) (Left NoDownload)
Right Right
@ -209,9 +208,9 @@ getDownloadURL' t v a p mv dls = maybe
-- --
-- The file must not exist. -- The file must not exist.
download :: Bool -- ^ https? download :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com") -> ByteString -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file") -> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000) -> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into -> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename -> Maybe (Path Rel) -- ^ optionally provided filename
-> IO (Path Abs) -> IO (Path Abs)
@ -222,22 +221,33 @@ download https host path port dest mfn = do
-- throw an exception if the url type or host protocol is not supported. -- throw an exception if the url type or host protocol is not supported.
-- --
-- Only Absolute HTTP/HTTPS is supported. -- Only Absolute HTTP/HTTPS is supported.
download' :: URL download' :: MonadIO m
=> URI
-> Path Abs -- ^ destination dir -> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
-> IO (Path Abs) -> Excepts '[URLException] m (Path Abs)
download' url dest mfn = case url of download' url dest mfn
URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] } | view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True
-> download https host path port dest mfn | view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False
_ -> fail ("Don't know how to handle URL: " <> exportURL url) | otherwise = throwE UnsupportedURL
where
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') url
?? UnsupportedURL
let path = view pathL' url
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
url
liftIO $ download https host path port dest mfn
-- | Same as 'download', except with a file descriptor. Allows to e.g. -- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout. -- print to stdout.
downloadFd :: Bool -- ^ https? downloadFd :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com") -> ByteString -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file") -> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000) -> Maybe Int -- ^ optional port (e.g. 3000)
-> Fd -- ^ function creating an Fd to write the body into -> Fd -- ^ function creating an Fd to write the body into
-> IO () -> IO ()
downloadFd https host path port fd = downloadFd https host path port fd =
@ -245,19 +255,19 @@ downloadFd https host path port fd =
downloadInternal :: Bool downloadInternal :: Bool
-> String -> ByteString
-> String -> ByteString
-> Maybe Integer -> Maybe Int
-> Either Fd (Path Abs, Maybe (Path Rel)) -> Either Fd (Path Abs, Maybe (Path Rel))
-> IO (Maybe (Path Abs)) -> IO (Maybe (Path Abs))
downloadInternal https host path port dest = do downloadInternal https host path port dest = do
c <- case https of c <- case https of
True -> do True -> do
ctx <- baselineContextSSL ctx <- baselineContextSSL
openConnectionSSL ctx (C.pack host) (fromIntegral $ fromMaybe 443 port) openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 port) False -> openConnection host (fromIntegral $ fromMaybe 80 port)
let q = buildRequest1 $ http GET (C.pack "/" <> C.pack path) let q = buildRequest1 $ http GET ([s|/|] <> path)
sendRequest c q emptyBody sendRequest c q emptyBody
@ -296,20 +306,12 @@ downloadInternal https host path port dest = do
Just x -> Just x ->
let fp = dest </> x let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> Nothing -> do
-- ...otherwise try to infer the filename from the URL path -- ...otherwise try to infer the filename from the URL path
case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path
Just x -> do fn' <- parseRel urlBaseName
fn' <- parseRel (C.pack $ T.unpack x) let fp = dest </> fn'
let fp = dest </> fn' fmap (, fp) $ createRegularFileFd newFilePerms fp
fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...if all fails, use a random filename!
(fp, handle) <- (mkstemp (toFilePath dest))
path <- parseAbs fp
fd <- handleToFd handle
pure (fd, path)
@ -372,7 +374,7 @@ getLinuxDistro = do
hasWord t matches = foldr hasWord t matches = foldr
(\x y -> (\x y ->
( isJust ( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b")) . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|]))
$ t $ t
) )
|| y || y
@ -401,9 +403,9 @@ getLinuxDistro = do
try_lsb_release_cmd = do try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd (Just _ ) <- findExecutable lsb_release_cmd
(Just name) <- (fmap . fmap) _stdOut (Just name) <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-si"] Nothing $ executeOut lsb_release_cmd [[s|-si|]] Nothing
ver <- (fmap . fmap) _stdOut ver <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-sr"] Nothing $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver) pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver)
try_lsb_release :: IO (Text, Maybe Text) try_lsb_release :: IO (Text, Maybe Text)
@ -419,14 +421,14 @@ getLinuxDistro = do
join join
. fmap (ICU.group 0) . fmap (ICU.group 0)
. ICU.find . ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b") (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|])
) )
$ t $ t
verRe = verRe =
join join
. fmap (ICU.group 0) . fmap (ICU.group 0)
. ICU.find . ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b")) (ICU.regex [ICU.CaseInsensitive] [s|\\b(\\d)+(.(\\d)+)*\\b|])
$ t $ t
(Just name) <- pure (Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat") (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
@ -454,32 +456,32 @@ unpackToTmpDir av = do
fn <- basename av fn <- basename av
let (fnrest, ext) = splitExtension $ toFilePath fn let (fnrest, ext) = splitExtension $ toFilePath fn
let ext2 = takeExtension fnrest let ext2 = takeExtension fnrest
tmpdir <- getEnvDefault (fS "TMPDIR") (fS "/tmp") tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> fS "ghcup-") tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do let untar bs = do
Tar.unpack tmp . Tar.read $ bs Tar.unpack tmp . Tar.read $ bs
Right <$> parseAbs tmp Right <$> parseAbs tmp
-- extract, depending on file extension -- extract, depending on file extension
if if
| ext == fS ".gz" && ext2 == fS ".tar" | ext == [s|.gz|] && ext2 == [s|.tar|]
-> untar . GZip.decompress =<< readFile av -> untar . GZip.decompress =<< readFile av
| ext == fS ".xz" && ext2 == fS ".tar" | ext == [s|.xz|] && ext2 == [s|.tar|]
-> do -> do
filecontents <- readFile av filecontents <- readFile av
let decompressed = Lzma.decompress filecontents let decompressed = Lzma.decompress filecontents
-- putStrLn $ show decompressed -- putStrLn $ show decompressed
untar decompressed untar decompressed
| ext == fS ".bz2" && ext2 == fS ".tar" | ext == [s|.bz2|] && ext2 == [s|.tar|]
-> untar . BZip.decompress =<< readFile av -> untar . BZip.decompress =<< readFile av
| ext == fS ".tar" && ext2 == fS ".tar" | ext == [s|.tar|]
-> untar =<< readFile av -> untar =<< readFile av
| otherwise | otherwise
-> pure $ Left $ UnknownArchive ext -> pure $ Left $ UnknownArchive ext
where where
isTar ext | ext == fS ".tar" = pure () isTar ext | ext == [s|.tar|] = pure ()
| otherwise = throwE $ UnknownArchive ext | otherwise = throwE $ UnknownArchive ext
-- | Install an unpacked GHC distribution. -- | Install an unpacked GHC distribution.
@ -487,8 +489,8 @@ installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> IO () -> IO ()
installGHC path inst = do installGHC path inst = do
exe (fS "./configure") [fS "--prefix=" <> toFilePath inst] False (Just path) exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path)
-- sh (fS "make") [fS "install"] (Just path) exec [s|make|] [[s|install|]] True (Just path)
pure () pure ()
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads -- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads

15
lib/GHCup/File.hs
View File

@ -159,15 +159,15 @@ createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm) FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
exe :: ByteString exec :: ByteString -- ^ thing to execute
-> [ByteString] -> [ByteString] -- ^ args for the thing
-> Bool -> Bool -- ^ whether to search PATH for the thing
-> Maybe (Path Abs) -> Maybe (Path Abs) -- ^ optionally chdir into this
-> IO (Either ProcessError ()) -> IO (Either ProcessError ())
exe exe' args spath chdir = do exec exe args spath chdir = do
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe' spath args Nothing SPPB.executeFile exe spath args Nothing
fmap toProcessError $ SPPB.getProcessStatus True True pid fmap toProcessError $ SPPB.getProcessStatus True True pid
@ -179,4 +179,3 @@ toProcessError mps = case mps of
Just (Terminated _ _ ) -> Left $ PTerminated Just (Terminated _ _ ) -> Left $ PTerminated
Just (Stopped _ ) -> Left $ PStopped Just (Stopped _ ) -> Left $ PStopped
Nothing -> Left $ NoSuchPid Nothing -> Left $ NoSuchPid

6
lib/GHCup/Types.hs
View File

@ -3,9 +3,9 @@
module GHCup.Types where module GHCup.Types where
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Network.URL
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
import Data.Versions import Data.Versions
import URI.ByteString
data Tool = GHC data Tool = GHC
@ -55,7 +55,7 @@ data PlatformRequest = PlatformRequest {
, _rVersion :: Maybe Versioning , _rVersion :: Maybe Versioning
} deriving (Eq, Show) } deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) URL type PlatformVersionSpec = Map (Maybe Versioning) URI
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version ArchitectureSpec type ToolVersionSpec = Map Version ArchitectureSpec
@ -63,5 +63,5 @@ type AvailableDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URL | OwnSource URI
| OwnSpec AvailableDownloads | OwnSpec AvailableDownloads

22
lib/GHCup/Types/JSON.hs
View File

@ -14,10 +14,13 @@ import GHCup.Types
import Data.Versions import Data.Versions
import Data.Aeson import Data.Aeson
import Data.Aeson.TH import Data.Aeson.TH
import Network.URL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8
, encodeUtf8
)
import Data.Aeson.Types import Data.Aeson.Types
import Data.Text.Encoding as E import Data.Text.Encoding as E
import URI.ByteString
@ -32,13 +35,14 @@ deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit deriveJSON defaultOptions ''VUnit
instance ToJSON URL where instance ToJSON URI where
toJSON = toJSON . exportURL toJSON = toJSON . decodeUtf8 . serializeURIRef'
instance FromJSON URL where instance FromJSON URI where
parseJSON = withText "URL" $ \t -> case importURL (T.unpack t) of parseJSON = withText "URL" $ \t ->
Just x -> pure x case parseURI strictURIParserOptions (encodeUtf8 t) of
Nothing -> fail "Could not parse URL, failure in importURL" Right x -> pure x
Left e -> fail . show $ e
instance ToJSON Versioning where instance ToJSON Versioning where
toJSON = toJSON . prettyV toJSON = toJSON . prettyV
@ -62,8 +66,8 @@ instance ToJSONKey (Maybe Versioning) where
Nothing -> T.pack "unknown_version" Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Versioning) where instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser fromJSONKey = FromJSONKeyTextParser $ \t ->
$ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where where
just t = case versioning t of just t = case versioning t of
Right x -> pure x Right x -> pure x

29
lib/GHCup/Types/Optics.hs
View File

@ -2,8 +2,10 @@
module GHCup.Types.Optics where module GHCup.Types.Optics where
import GHCup.Types import Data.ByteString ( ByteString )
import Optics import GHCup.Types
import Optics
import URI.ByteString
makePrisms ''Tool makePrisms ''Tool
makePrisms ''Architecture makePrisms ''Architecture
@ -14,3 +16,26 @@ makeLenses ''PlatformResult
makeLenses ''ToolRequest makeLenses ''ToolRequest
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL
schemeBSL' :: Lens' Scheme ByteString
schemeBSL' = lensVL schemeBSL
authorityL' :: Lens' (URIRef a) (Maybe Authority)
authorityL' = lensVL authorityL
authorityHostL' :: Lens' Authority Host
authorityHostL' = lensVL authorityHostL
authorityPortL' :: Lens' Authority (Maybe Port)
authorityPortL' = lensVL authorityPortL
portNumberL' :: Lens' Port Int
portNumberL' = lensVL portNumberL
hostBSL' :: Lens' Host ByteString
hostBSL' = lensVL hostBSL
pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL