diff --git a/cabal.project.freeze b/cabal.project.freeze index 12188fe..11d0a55 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -142,7 +142,7 @@ constraints: any.Cabal ==2.4.0.1, any.syb ==0.7.1, any.tagged ==0.8.6, 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.terminfo ==0.4.1.2, any.text ==1.2.3.1, diff --git a/ghcup.cabal b/ghcup.cabal index 320d96c..cead7f5 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -40,23 +40,26 @@ common language-bash { build-depends: language-bash >= 0.9 } common lzma { build-depends: lzma >= 0.0.0.3 } common mtl { build-depends: mtl >= 2.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 safe-exceptions { build-depends: safe-exceptions >= 0.1 } common streamly { build-depends: streamly >= 0.7 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } 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 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 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 vector { build-depends: vector >= 0.12 } common versions { build-depends: versions >= 3.5 } common waargonaut { build-depends: waargonaut >= 0.8 } +common word8 { build-depends: word8 >= 0.1.3 } common zlib { build-depends: zlib >= 0.6.2.1 } @@ -95,11 +98,13 @@ library , lzma , mtl , optics + , optics-vl , parsec , safe-exceptions , streamly , streamly-bytestring , strict-base + , string-qq , tar-bytestring , template-haskell , text @@ -107,10 +112,11 @@ library , transformers , unix , unix-bytestring - , url + , uri-bytestring , utf8-string , vector , versions + , word8 , zlib exposed-modules: GHCup GHCup.Bash diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 91b72b1..b14b046 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} -- TODO: handle SIGTERM, SIGUSR module GHCup where @@ -19,6 +19,7 @@ import Control.Monad.IO.Class import Control.Exception.Safe import Data.ByteString ( ByteString ) import Data.Foldable ( asum ) +import Data.String.QQ import Data.Text ( Text ) import Data.Versions import GHCup.Bash @@ -28,7 +29,6 @@ import GHCup.Types import GHCup.Types.Optics import HPath import HPath.IO -import Network.URL import Optics import Prelude hiding ( abs , readFile @@ -36,10 +36,11 @@ import Prelude hiding ( abs import System.Info import System.IO.Error 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 Data.Maybe import qualified Data.Map.Strict as Map +import Data.Word8 import GHC.IO.Exception import GHC.IO.Handle 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 System.Posix.Process.ByteString 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 deriving Show +data URLException = UnsupportedURL + deriving Show + ---------------------- @@ -107,32 +114,29 @@ data ArchiveError = UnknownArchive ByteString ---------------------- - +-- TODO: version quasiquoter availableDownloads :: AvailableDownloads availableDownloads = Map.fromList [ ( GHC , Map.fromList - [ ( (\(Right x) -> x) $ version (fS "8.6.5") + [ ( (\(Right x) -> x) $ version [s|8.6.5|] , Map.fromList [ ( A_64 , Map.fromList [ ( Linux UnknownLinux , Map.fromList [ ( Nothing - , mkGHCUrl - "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz" + , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|] ) ] ) , ( Linux Debian , Map.fromList [ ( Nothing - , mkGHCUrl - "~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz" + , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|] ) - , ( Just $ (\(Right x) -> x) $ versioning (fS "8") - , mkGHCUrl - "~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz" + , ( Just $ (\(Right x) -> x) $ versioning [s|8|] + , [uri|https://downloads.haskell.org/~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) @@ -158,7 +157,7 @@ getDownloadURL :: (MonadCatch m, MonadIO m) -> Excepts '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] m - URL + URI getDownloadURL (ToolRequest t v) mpfReq urlSource = do (PlatformRequest arch plat ver) <- case mpfReq of Just x -> pure x @@ -185,7 +184,7 @@ getDownloadURL' :: Tool -> Maybe Versioning -- ^ optional version of the platform -> AvailableDownloads - -> Either NoDownload URL + -> Either NoDownload URI getDownloadURL' t v a p mv dls = maybe (Left NoDownload) Right @@ -209,9 +208,9 @@ getDownloadURL' t v a p mv dls = maybe -- -- The file must not exist. download :: Bool -- ^ https? - -> String -- ^ host (e.g. "www.example.com") - -> String -- ^ path (e.g. "/my/file") - -> Maybe Integer -- ^ optional port (e.g. 3000) + -> ByteString -- ^ host (e.g. "www.example.com") + -> ByteString -- ^ path (e.g. "/my/file") + -> Maybe Int -- ^ optional port (e.g. 3000) -> Path Abs -- ^ destination directory to download into -> Maybe (Path Rel) -- ^ optionally provided filename -> 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. -- -- Only Absolute HTTP/HTTPS is supported. -download' :: URL +download' :: MonadIO m + => URI -> Path Abs -- ^ destination dir -> Maybe (Path Rel) -- ^ optional filename - -> IO (Path Abs) -download' url dest mfn = case url of - URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] } - -> download https host path port dest mfn - _ -> fail ("Don't know how to handle URL: " <> exportURL url) + -> Excepts '[URLException] m (Path Abs) +download' url dest mfn + | view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True + | view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False + | 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. -- print to stdout. downloadFd :: Bool -- ^ https? - -> String -- ^ host (e.g. "www.example.com") - -> String -- ^ path (e.g. "/my/file") - -> Maybe Integer -- ^ optional port (e.g. 3000) + -> ByteString -- ^ host (e.g. "www.example.com") + -> ByteString -- ^ path (e.g. "/my/file") + -> Maybe Int -- ^ optional port (e.g. 3000) -> Fd -- ^ function creating an Fd to write the body into -> IO () downloadFd https host path port fd = @@ -245,19 +255,19 @@ downloadFd https host path port fd = downloadInternal :: Bool - -> String - -> String - -> Maybe Integer + -> ByteString + -> ByteString + -> Maybe Int -> Either Fd (Path Abs, Maybe (Path Rel)) -> IO (Maybe (Path Abs)) downloadInternal https host path port dest = do c <- case https of True -> do ctx <- baselineContextSSL - openConnectionSSL ctx (C.pack host) (fromIntegral $ fromMaybe 443 port) - False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 port) + openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 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 @@ -296,20 +306,12 @@ downloadInternal https host path port dest = do Just x -> let fp = dest x in fmap (, fp) $ createRegularFileFd newFilePerms fp - Nothing -> + Nothing -> do -- ...otherwise try to infer the filename from the URL path - case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of - Just x -> do - fn' <- parseRel (C.pack $ T.unpack x) - let fp = dest fn' - 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) - + let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path + fn' <- parseRel urlBaseName + let fp = dest fn' + fmap (, fp) $ createRegularFileFd newFilePerms fp @@ -372,7 +374,7 @@ getLinuxDistro = do hasWord t matches = foldr (\x y -> ( isJust - . ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b")) + . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|])) $ t ) || y @@ -401,9 +403,9 @@ getLinuxDistro = do try_lsb_release_cmd = do (Just _ ) <- findExecutable lsb_release_cmd (Just name) <- (fmap . fmap) _stdOut - $ executeOut lsb_release_cmd [fS "-si"] Nothing + $ executeOut lsb_release_cmd [[s|-si|]] Nothing 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) try_lsb_release :: IO (Text, Maybe Text) @@ -419,14 +421,14 @@ getLinuxDistro = do join . fmap (ICU.group 0) . ICU.find - (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b") + (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|]) ) $ t verRe = join . fmap (ICU.group 0) . ICU.find - (ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b")) + (ICU.regex [ICU.CaseInsensitive] [s|\\b(\\d)+(.(\\d)+)*\\b|]) $ t (Just name) <- pure (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat") @@ -454,32 +456,32 @@ unpackToTmpDir av = do fn <- basename av let (fnrest, ext) = splitExtension $ toFilePath fn let ext2 = takeExtension fnrest - tmpdir <- getEnvDefault (fS "TMPDIR") (fS "/tmp") - tmp <- mkdtemp $ (tmpdir FP. fS "ghcup-") + tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|] + tmp <- mkdtemp $ (tmpdir FP. [s|ghcup-|]) let untar bs = do Tar.unpack tmp . Tar.read $ bs Right <$> parseAbs tmp -- extract, depending on file extension if - | ext == fS ".gz" && ext2 == fS ".tar" + | ext == [s|.gz|] && ext2 == [s|.tar|] -> untar . GZip.decompress =<< readFile av - | ext == fS ".xz" && ext2 == fS ".tar" + | ext == [s|.xz|] && ext2 == [s|.tar|] -> do filecontents <- readFile av let decompressed = Lzma.decompress filecontents -- putStrLn $ show decompressed untar decompressed - | ext == fS ".bz2" && ext2 == fS ".tar" + | ext == [s|.bz2|] && ext2 == [s|.tar|] -> untar . BZip.decompress =<< readFile av - | ext == fS ".tar" && ext2 == fS ".tar" + | ext == [s|.tar|] -> untar =<< readFile av | otherwise -> pure $ Left $ UnknownArchive ext where - isTar ext | ext == fS ".tar" = pure () - | otherwise = throwE $ UnknownArchive ext + isTar ext | ext == [s|.tar|] = pure () + | otherwise = throwE $ UnknownArchive ext -- | Install an unpacked GHC distribution. @@ -487,8 +489,8 @@ installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist -> Path Abs -- ^ Path to install to -> IO () installGHC path inst = do - exe (fS "./configure") [fS "--prefix=" <> toFilePath inst] False (Just path) - -- sh (fS "make") [fS "install"] (Just path) + exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path) + exec [s|make|] [[s|install|]] True (Just path) pure () -- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 6b6f703..5edd922 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -159,15 +159,15 @@ createRegularFileFd fm dest = FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm) -exe :: ByteString - -> [ByteString] - -> Bool - -> Maybe (Path Abs) - -> IO (Either ProcessError ()) -exe exe' args spath chdir = do +exec :: ByteString -- ^ thing to execute + -> [ByteString] -- ^ args for the thing + -> Bool -- ^ whether to search PATH for the thing + -> Maybe (Path Abs) -- ^ optionally chdir into this + -> IO (Either ProcessError ()) +exec exe args spath chdir = do pid <- SPPB.forkProcess $ do maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir - SPPB.executeFile exe' spath args Nothing + SPPB.executeFile exe spath args Nothing fmap toProcessError $ SPPB.getProcessStatus True True pid @@ -179,4 +179,3 @@ toProcessError mps = case mps of Just (Terminated _ _ ) -> Left $ PTerminated Just (Stopped _ ) -> Left $ PStopped Nothing -> Left $ NoSuchPid - diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 247c029..95e9a6c 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -3,9 +3,9 @@ module GHCup.Types where import Data.Map.Strict ( Map ) -import Network.URL import qualified GHC.Generics as GHC import Data.Versions +import URI.ByteString data Tool = GHC @@ -55,7 +55,7 @@ data PlatformRequest = PlatformRequest { , _rVersion :: Maybe Versioning } deriving (Eq, Show) -type PlatformVersionSpec = Map (Maybe Versioning) URL +type PlatformVersionSpec = Map (Maybe Versioning) URI type PlatformSpec = Map Platform PlatformVersionSpec type ArchitectureSpec = Map Architecture PlatformSpec type ToolVersionSpec = Map Version ArchitectureSpec @@ -63,5 +63,5 @@ type AvailableDownloads = Map Tool ToolVersionSpec data URLSource = GHCupURL - | OwnSource URL + | OwnSource URI | OwnSpec AvailableDownloads diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 175d381..f737af6 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -14,10 +14,13 @@ import GHCup.Types import Data.Versions import Data.Aeson import Data.Aeson.TH -import Network.URL import qualified Data.Text as T +import Data.Text.Encoding ( decodeUtf8 + , encodeUtf8 + ) import Data.Aeson.Types import Data.Text.Encoding as E +import URI.ByteString @@ -32,13 +35,14 @@ deriveJSON defaultOptions ''VSep deriveJSON defaultOptions ''VUnit -instance ToJSON URL where - toJSON = toJSON . exportURL +instance ToJSON URI where + toJSON = toJSON . decodeUtf8 . serializeURIRef' -instance FromJSON URL where - parseJSON = withText "URL" $ \t -> case importURL (T.unpack t) of - Just x -> pure x - Nothing -> fail "Could not parse URL, failure in importURL" +instance FromJSON URI where + parseJSON = withText "URL" $ \t -> + case parseURI strictURIParserOptions (encodeUtf8 t) of + Right x -> pure x + Left e -> fail . show $ e instance ToJSON Versioning where toJSON = toJSON . prettyV @@ -62,8 +66,8 @@ instance ToJSONKey (Maybe Versioning) where Nothing -> T.pack "unknown_version" instance FromJSONKey (Maybe Versioning) where - fromJSONKey = FromJSONKeyTextParser - $ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t + fromJSONKey = FromJSONKeyTextParser $ \t -> + if t == T.pack "unknown_version" then pure Nothing else pure $ just t where just t = case versioning t of Right x -> pure x diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index 061fc4d..2d2b832 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -2,8 +2,10 @@ module GHCup.Types.Optics where -import GHCup.Types -import Optics +import Data.ByteString ( ByteString ) +import GHCup.Types +import Optics +import URI.ByteString makePrisms ''Tool makePrisms ''Architecture @@ -14,3 +16,26 @@ makeLenses ''PlatformResult 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