More work

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

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
+getDownloadURL :: ToolRequest
-            -> Maybe PlatformRequest
+               -> Maybe PlatformRequest
-            -> URLSource
+               -> URLSource
-            -> IO (Maybe URL) -- TODO: better error handling
+               -> IO (Maybe URL) -- TODO: better error handling
-downloadURL (ToolRequest t v) mpfReq urlSource = do
+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
+getDownloadURL' :: Tool
-             -> Version
+                -> Version
              -- ^ tool version
-             -> Architecture
+                -> Architecture
              -- ^ user arch
-             -> Platform
+                -> Platform
              -- ^ user platform
-             -> Maybe Versioning
+                -> Maybe Versioning
              -- ^ optional version of the platform
-             -> AvailableDownloads
+                -> AvailableDownloads
-             -> Maybe URL
+                -> Maybe URL
-downloadURL' t v a p mv dls =
+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 ["debian"]  -> Debian
-        | hasWord name (T.pack <$> ["ubuntu"])  -> Ubuntu
+        | hasWord name ["ubuntu"]  -> Ubuntu
-        | hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
+        | hasWord name ["linuxmint", "Linux Mint"] -> Mint
-        | hasWord name (T.pack <$> ["fedora"])  -> Fedora
+        | hasWord name ["fedora"]  -> Fedora
-        | hasWord name (T.pack <$> ["centos"])  -> CentOS
+        | hasWord name ["centos"]  -> CentOS
-        | hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
+        | hasWord name ["Red Hat"] -> RedHat
-        | hasWord name (T.pack <$> ["alpine"])  -> Alpine
+        | hasWord name ["alpine"]  -> Alpine
-        | hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
+        | hasWord name ["exherbo"] -> Exherbo
-        | hasWord name (T.pack <$> ["gentoo"])  -> Gentoo
+        | hasWord name ["gentoo"]  -> Gentoo
-        | otherwise                             -> UnknownLinux
+        | 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 _   ) <- findExecutable lsb_release_cmd
-    (Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
+    (Just name) <- (fmap . fmap) _stdOut
-    ver              <- executeOut lsb_release_cmd [fS "-sr"]
+      $ executeOut lsb_release_cmd [fS "-si"]
-    pure (lBS2sT name, fmap (lBS2sT . fst) ver)
+    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

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.
+-- | Execute the given command and collect the stdout, stderr and the exit code.
-executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
+-- 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
+           -> IO (Maybe CapturedProcess)
-executeOut path args = withFnPath path $ \fp -> do
+executeOut path args = withFnPath path
-  (parentRead, childWrite) <- createPipe
+  $ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing
-  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
 
-  closeFd childWrite
 
-  SPPB.getProcessStatus True True pid >>= \case
+-- | Capture the stdout and stderr of the given action, which
-    -- readE will take care of closing the fd
+-- is run in a subprocess. Stdin is closed. You might want to
-    Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
+-- 'race' this to make sure it terminates.
-    _                     -> closeFd parentRead $> Nothing
+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)

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 :: S.Maybe a -> Maybe a
-fromStrictMaybe = maybe P.Nothing P.Just
+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 :: Maybe a -> S.Maybe a
-toStrictMaybe = P.maybe Nothing Just
+toStrictMaybe = maybe S.Nothing S.Just
 
-tSM :: P.Maybe a -> Maybe a
+tSM :: Maybe a -> S.Maybe a
 tSM = toStrictMaybe
 
-instance Applicative Maybe where
+internalError :: String -> IO a
-  pure = Just
+internalError = fail . ("Internal error: " <>)
 
-  Just f  <*> m  = P.fmap f m
+iE :: String -> IO a
-  Nothing <*> _m = Nothing
+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)
+

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

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