From d3072a88b81a8bd3699b1cc0244d7d3d4c0ffcc0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 17 Jan 2020 23:29:16 +0100 Subject: [PATCH] More work --- ghcup.cabal | 25 ++++-- lib/GHCup.hs | 193 +++++++++++++++++++++++++++++++++------- lib/GHCup/File.hs | 102 ++++++++++++++++----- lib/GHCup/Prelude.hs | 55 +++++------- lib/GHCup/Types.hs | 9 ++ lib/GHCup/Types/JSON.hs | 4 +- 6 files changed, 296 insertions(+), 92 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index 582186c..4fea505 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -20,16 +20,21 @@ source-repository head type: git location: https://github.com/hasufell/ghcup-hs +common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 } 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 async { build-depends: async >= 0.8 } +common base { build-depends: base >= 4.12 && < 5 } common bytestring { build-depends: bytestring >= 0.10 } common containers { build-depends: containers >= 0.6 } common generics-sop { build-depends: generics-sop >= 0.5 } common hpath { build-depends: hpath >= 0.10.1 } common hpath-filepath { build-depends: hpath-filepath >= 0.10 } common hpath-io { build-depends: hpath-io >= 0.10.1 } +common http-io-streams { build-depends: http-io-streams >= 0.1 } +common io-streams { build-depends: io-streams >= 1.5 } common language-bash { build-depends: language-bash >= 0.9 } +common mtl { build-depends: mtl >= 2.2 } common optics { build-depends: optics >= 0.2 } common parsec { build-depends: parsec >= 3.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 } @@ -40,24 +45,31 @@ 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 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 waargonaut { build-depends: waargonaut >= 0.8 } common config default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 - default-extensions: LambdaCase, MultiWayIf, ScopedTypeVariables, StrictData, Strict, TupleSections + default-extensions: LambdaCase + , MultiWayIf + , PackageImports + , RecordWildCards + , ScopedTypeVariables + , StrictData + , Strict + , TupleSections library import: config , base -- deps + , HsOpenSSL , aeson , ascii-string , async @@ -67,6 +79,8 @@ library , hpath , hpath-filepath , hpath-io + , http-io-streams + , io-streams , language-bash , mtl , optics @@ -79,6 +93,7 @@ library , text-icu , transformers , unix + , unix-bytestring , url , utf8-string , vector diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8cad6a6..7fe0217 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -13,6 +13,9 @@ module GHCup where import Control.Applicative import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Control.Exception.Safe import Data.Foldable ( asum ) import Data.Text ( Text ) import Data.Versions @@ -29,10 +32,32 @@ import Prelude hiding ( abs , readFile ) import System.Info +import System.IO.Error import qualified Data.Text as T import qualified Data.Text.ICU as ICU -import Data.Maybe ( isJust ) +import Data.Maybe import qualified Data.Map.Strict as Map +import GHC.IO.Exception +import GHC.IO.Handle +import Network.Http.Client hiding ( URL ) +import System.IO.Streams ( InputStream + , OutputStream + , stdout + ) +import qualified System.IO.Streams as Streams +import System.Posix.Temp.ByteString +import "unix" System.Posix.IO.ByteString + hiding ( fdWrite ) +import System.Posix.FD as FD +import System.Posix.Directory.Foreign ( oTrunc ) +import qualified Data.ByteString as B +import OpenSSL ( withOpenSSL ) +import qualified Data.ByteString.Char8 as C +import Data.Functor ( ($>) ) +import System.Posix.Types +import "unix-bytestring" System.Posix.IO.ByteString + ( fdWrite ) + availableDownloads :: AvailableDownloads @@ -78,11 +103,11 @@ availableDownloads = Map.fromList } -downloadURL :: ToolRequest - -> Maybe PlatformRequest - -> URLSource - -> IO (Maybe URL) -- TODO: better error handling -downloadURL (ToolRequest t v) mpfReq urlSource = do +getDownloadURL :: ToolRequest + -> Maybe PlatformRequest + -> URLSource + -> IO (Maybe URL) -- TODO: better error handling +getDownloadURL (ToolRequest t v) mpfReq urlSource = do (PlatformRequest arch plat ver) <- case mpfReq of Just x -> pure x Nothing -> do @@ -95,21 +120,21 @@ downloadURL (ToolRequest t v) mpfReq urlSource = do OwnSource url -> fail "Not implemented" OwnSpec dls -> pure dls - pure $ downloadURL' t v arch plat ver dls + pure $ getDownloadURL' t v arch plat ver dls -downloadURL' :: Tool - -> Version +getDownloadURL' :: Tool + -> Version -- ^ tool version - -> Architecture + -> Architecture -- ^ user arch - -> Platform + -> Platform -- ^ user platform - -> Maybe Versioning + -> Maybe Versioning -- ^ optional version of the platform - -> AvailableDownloads - -> Maybe URL -downloadURL' t v a p mv dls = + -> AvailableDownloads + -> Maybe URL +getDownloadURL' t v a p mv dls = with_distro <|> without_distro_ver <|> without_distro where @@ -156,16 +181,16 @@ getLinuxDistro = do ] 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 + | hasWord name ["debian"] -> Debian + | hasWord name ["ubuntu"] -> Ubuntu + | hasWord name ["linuxmint", "Linux Mint"] -> Mint + | hasWord name ["fedora"] -> Fedora + | hasWord name ["centos"] -> CentOS + | hasWord name ["Red Hat"] -> RedHat + | hasWord name ["alpine"] -> Alpine + | hasWord name ["exherbo"] -> Exherbo + | hasWord name ["gentoo"] -> Gentoo + | otherwise -> UnknownLinux pure (distro, parsedVer) where hasWord t matches = foldr @@ -177,7 +202,7 @@ getLinuxDistro = do || y ) False - matches + (T.pack <$> matches) os_release :: Path Abs os_release = [abs|/etc/os-release|] @@ -198,10 +223,11 @@ getLinuxDistro = do 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) + (Just _ ) <- findExecutable lsb_release_cmd + (Just name) <- (fmap . fmap) _stdOut + $ executeOut lsb_release_cmd [fS "-si"] + ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [fS "-sr"] + pure (lBS2sT name, fmap lBS2sT ver) try_lsb_release :: IO (Text, Maybe Text) try_lsb_release = do @@ -236,11 +262,114 @@ getLinuxDistro = do pure (T.pack "debian", Just $ lBS2sT ver) +-- | Tries to download from the given http or https url +-- and saves the result in continuous memory into a file. +-- If the filename is not provided, then we: +-- 1. try to guess the filename from the url path +-- 2. otherwise create a random file +-- +-- 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) + -> Path Abs -- ^ destination directory to download into + -> Maybe (Path Fn) -- ^ optionally provided filename + -> IO (Path Abs) +download https host path port dest mfn = do + fromJust <$> downloadInternal https host path port (Right (dest, mfn)) + +-- | Same as 'download', except uses URL type. As such, this might +-- throw an exception if the url type or host protocol is not supported. +-- +-- Only Absolute HTTP/HTTPS is supported. +download' :: URL -> Path Abs -> Maybe (Path Fn) -> 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) + + +-- | 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) + -> Fd -- ^ function creating an Fd to write the body into + -> IO () +downloadFd https host path port fd = + void $ downloadInternal https host path port (Left fd) + + +downloadInternal :: Bool + -> String + -> String + -> Maybe Integer + -> Either Fd (Path Abs, Maybe (Path Fn)) + -> 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) + + let q = buildRequest1 $ http GET (C.pack "/" <> C.pack path) + + sendRequest c q emptyBody + + (fd, mfp) <- case dest of + Right (dest, mfn) -> getFile dest mfn <&> (<&> Just) + Left fd -> pure (fd, Nothing) + + -- wrapper so we can close Fds we created + let receiveResponse' c b = case dest of + Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b + Left _ -> receiveResponse c b + + receiveResponse' + c + (\p i -> do + outStream <- Streams.makeOutputStream + (\case + Just bs -> void $ fdWrite fd bs + Nothing -> pure () + ) + Streams.connect i outStream + ) + + closeConnection c + + pure mfp + + where + -- Manage to find a file we can write the body into. + getFile :: Path Abs -> Maybe (Path Fn) -> IO (Fd, Path Abs) + getFile dest mfn = do + -- destination dir must exist + hideError AlreadyExists $ createDirRecursive newDirPerms dest + case mfn of + -- if a filename was provided, try that + Just x -> + let fp = dest x + in fmap (, fp) $ createRegularFileFd newFilePerms fp + Nothing -> + -- ...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' <- parseFn (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) --- download :: URL -> Path Abs -> IO (Path Abs) --- download = undefined -- unpack :: Path Abs -> IO (Path Abs) -- unpack = undefined diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 7e9c07b..1e2adf5 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + module GHCup.File where import Data.ByteString @@ -6,6 +8,7 @@ import Data.Char import Data.Maybe import HPath import HPath.IO +import Optics import Streamly.ByteString import Streamly import System.Posix.FilePath hiding ( () ) @@ -14,8 +17,9 @@ import Control.Monad import Control.Exception.Safe import Data.Functor import System.Posix.Files.ByteString +import System.Posix.Directory.Foreign ( oExcl ) import System.IO -import System.Posix.IO.ByteString +import "unix" System.Posix.IO.ByteString hiding ( openFd ) import qualified System.Posix.Process.ByteString as SPPB @@ -31,6 +35,18 @@ import qualified Streamly.Data.Fold as FL import Data.ByteString.Builder import Foreign.C.Error import GHCup.Prelude +import Control.Concurrent.Async +import Control.Concurrent +import System.Posix.FD as FD + + +data CapturedProcess = CapturedProcess { + _exitCode :: ExitCode + , _stdOut :: L.ByteString + , _stdErr :: L.ByteString +} deriving (Eq, Show) + +makeLenses ''CapturedProcess -- |Checks whether a file is executable. Follows symlinks. @@ -84,26 +100,70 @@ findExecutable ex = do sPaths --- | Execute the given command and collect the stdout and the exit code. -executeOut :: Path Fn -- ^ command as filename, e.g. 'ls' +-- | Execute the given command and collect the stdout, stderr and the exit code. +-- The command is run in a subprocess. +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 - (parentRead, childWrite) <- createPipe - pid <- SPPB.forkProcess $ do - whileM_ - (dupTo childWrite stdOutput) - (\r -> - getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR - ) - closeFd childWrite - closeFd parentRead - closeFd stdInput - SPPB.executeFile fp True args Nothing + -> IO (Maybe CapturedProcess) +executeOut path args = withFnPath path + $ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing - closeFd childWrite - SPPB.getProcessStatus True True pid >>= \case - -- readE will take care of closing the fd - Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es) - _ -> closeFd parentRead $> Nothing +-- | Capture the stdout and stderr of the given action, which +-- is run in a subprocess. Stdin is closed. You might want to +-- 'race' this to make sure it terminates. +captureOutStreams :: IO a + -- ^ the action to execute in a subprocess + -> IO (Maybe CapturedProcess) +captureOutStreams action = + actionWithPipes $ \(parentStdoutRead, childStdoutWrite) -> + actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do + pid <- SPPB.forkProcess $ do + -- don't mess up stdin from the parent + closeFd stdInput + + -- dup stdout + void $ dupTo childStdoutWrite stdOutput + closeFd childStdoutWrite + closeFd parentStdoutRead + + -- dup stderr + void $ dupTo childStderrWrite stdError + closeFd childStderrWrite + closeFd parentStderrRead + + -- execute the action + void $ action + + -- close everything we don't need + closeFd childStdoutWrite + closeFd childStderrWrite + + SPPB.getProcessStatus True True pid >>= \case + -- readFd will take care of closing the fd + Just (SPPB.Exited es) -> do + stdout' <- readFd parentStdoutRead + stderr' <- readFd parentStderrRead + pure $ Just $ CapturedProcess { _exitCode = es + , _stdOut = stdout' + , _stdErr = stderr' + } + _ -> do + closeFd parentStdoutRead + closeFd parentStderrRead + pure $ Nothing + + where + actionWithPipes a = + createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2) + cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd + + + +-- | Create a new regular file in write-only mode. The file must not exist. +createRegularFileFd :: FileMode -> Path b -> IO Fd +createRegularFileFd fm dest = FD.openFd + (toFilePath dest) + WriteOnly + [oExcl] + (Just fm) diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index 5e0dba5..f7003ec 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -6,57 +6,39 @@ module GHCup.Prelude where import Control.Applicative import Control.Monad -import Data.Strict.Maybe +import Control.Exception.Safe +import qualified Data.Strict.Maybe as S 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 +import System.IO.Error -fS :: IsString a => P.String -> a +fS :: IsString a => String -> a fS = fromString -fromStrictMaybe :: Maybe a -> P.Maybe a -fromStrictMaybe = maybe P.Nothing P.Just +fromStrictMaybe :: S.Maybe a -> Maybe a +fromStrictMaybe = S.maybe Nothing Just -fSM :: Maybe a -> P.Maybe a +fSM :: S.Maybe a -> Maybe a fSM = fromStrictMaybe -toStrictMaybe :: P.Maybe a -> Maybe a -toStrictMaybe = P.maybe Nothing Just +toStrictMaybe :: Maybe a -> S.Maybe a +toStrictMaybe = maybe S.Nothing S.Just -tSM :: P.Maybe a -> Maybe a +tSM :: Maybe a -> S.Maybe a tSM = toStrictMaybe -instance Applicative Maybe where - pure = Just +internalError :: String -> IO a +internalError = fail . ("Internal error: " <>) - Just f <*> m = P.fmap f m - Nothing <*> _m = Nothing +iE :: String -> IO a +iE = internalError - liftA2 f (Just x) (Just y) = Just (f x y) - liftA2 _ _ _ = Nothing - - Just _m1 *> m2 = m2 - Nothing *> _m2 = Nothing - -instance Alternative Maybe where - empty = Nothing - Nothing <|> r = r - l <|> _ = l - - -internalError :: P.String -> P.IO a -internalError = P.fail . ("Internal error: " <>) -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () @@ -86,3 +68,12 @@ guardM ~f = guard =<< f lBS2sT :: L.ByteString -> Text lBS2sT = TL.toStrict . TLE.decodeUtf8 + + +handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO () +handleIO' err handler = + handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) + +hideError :: IOErrorType -> IO () -> IO () +hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e) + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 247c029..a7432b5 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -6,7 +6,16 @@ import Data.Map.Strict ( Map ) import Network.URL import qualified GHC.Generics as GHC import Data.Versions +import HPath +import System.Posix.Types +data DownloadDestination = DPath { + dDestDir :: Path Abs + , dFileName :: Maybe (Path Fn) + } | + Fd { + dFd :: Fd + } data Tool = GHC | Cabal diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 5b21af0..175d381 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -59,11 +59,11 @@ instance FromJSONKey Versioning where instance ToJSONKey (Maybe Versioning) where toJSONKey = toJSONKeyText $ \case Just x -> prettyV x - Nothing -> T.pack "unknown" + Nothing -> T.pack "unknown_version" instance FromJSONKey (Maybe Versioning) where fromJSONKey = FromJSONKeyTextParser - $ \t -> if t == T.pack "unknown" then pure Nothing else pure $ just t + $ \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