Lala

.gitlab-ci.yml

@@ -113,7 +113,7 @@ test:linux:recommended:
 test:linux:latest:
   extends: .test_ghcup_version:linux
   variables:
-    GHC_VERSION: "8.10.1"
+    GHC_VERSION: "8.10.2"
     CABAL_VERSION: "3.2.0.0"
   allow_failure: true
 
@@ -136,7 +136,7 @@ test:mac:recommended:
 test:mac:latest:
   extends: .test_ghcup_version:darwin
   variables:
-    GHC_VERSION: "8.10.1"
+    GHC_VERSION: "8.10.2"
     CABAL_VERSION: "3.2.0.0"
   allow_failure: true
 
@@ -152,7 +152,7 @@ test:freebsd:recommended:
 test:freebsd:latest:
   extends: .test_ghcup_version:freebsd
   variables:
-    GHC_VERSION: "8.10.1"
+    GHC_VERSION: "8.10.2"
     CABAL_VERSION: "3.2.0.0"
   allow_failure: true
 

CHANGELOG.md

@@ -1,6 +1,6 @@
 # Revision history for ghcup
 
-## 0.1.10 -- yyyy-mm-dd
+## 0.1.10 -- 2020-08-14
 
 * Show stray Cabals (useful for pre-releases or compiled ones)
 

app/ghcup-gen/Validate.hs

@@ -8,6 +8,7 @@ import           GHCup
 import           GHCup.Download
 import           GHCup.Types
 import           GHCup.Utils.Dirs
+import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 import           GHCup.Utils.Version.QQ
 
@@ -192,7 +193,7 @@ validateTarballs dls = do
  where
   downloadAll dli = do
     dirs <- liftIO getDirs
-    let settings = Settings True False Never Curl False dirs
+    let settings = Settings True False Never Curl False dirs defExecCb
     let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
                                            , colorOutter  = B.hPut stderr
                                            , rawOutter    = (\_ -> pure ())

app/ghcup/BrickMain.hs

@@ -14,8 +14,10 @@ import           GHCup.Types
 import           GHCup.Utils
 import           GHCup.Utils.File
 import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
 
 import           Brick
+import           Brick.BChan
 import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Center
@@ -23,11 +25,14 @@ import           Brick.Widgets.List
 #if !defined(TAR)
 import           Codec.Archive
 #endif
+import           Control.Concurrent
+import           Control.Concurrent.MVar
 import           Control.Exception.Safe
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
 import           Data.Bool
+import           Data.ByteString                ( ByteString )
 import           Data.Functor
 import           Data.List
 import           Data.Maybe
@@ -37,22 +42,40 @@ import           Data.String.Interpolate
 import           Data.Vector                    ( Vector )
 import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
-import           Prelude                 hiding ( appendFile )
+import           HPath
+import           HPath.IO                hiding ( hideError )
+import           Prelude                 hiding ( abs, appendFile, writeFile )
 import           System.Exit
 import           System.IO.Unsafe
+import           System.Posix.Types
 import           URI.ByteString
 
 import qualified Data.Text                     as T
 import qualified Graphics.Vty                  as Vty
 import qualified Data.Vector                   as V
+import qualified "unix-bytestring" System.Posix.IO.ByteString
+                                               as SPIB
 
+data SubProcess = SubProcess {
+    procName :: String
+  , exited   :: Maybe (Either ProcessError ())
+  , procId   :: Maybe ProcessID
+  , logLine  :: Maybe ByteString
+}
 
 data AppState = AppState {
-    lr :: LR
+    lr    :: LR
-  , dls :: GHCupDownloads
+  , dls   :: GHCupDownloads
   , pfreq :: PlatformRequest
+
+  , mproc :: Maybe SubProcess
 }
 
+data MyAppEvent = LogLine ByteString
+                | StartProc String
+                | GotProcId ProcessID
+                | EndProc (Either ProcessError ())
+
 type LR = GenericList String Vector ListResult
 
 
@@ -68,21 +91,28 @@ keyHandlers =
 
 ui :: AppState -> Widget String
 ui AppState {..} =
-  ( padBottom Max
+  case mproc of
-    $ ( withBorderStyle unicode
+    Just _ -> logDialog
-      $ borderWithLabel (str "GHCup")
+    Nothing ->
-      $ (center $ renderList renderItem True lr)
+              ( padBottom Max
-      )
+                $ ( withBorderStyle unicode
-    )
+                  $ borderWithLabel (str "GHCup")
-    <=> ( withAttr "help"
+                  $ (center $ renderList renderItem True lr)
-        . txtWrap
+                  )
-        . T.pack
+                )
-        . foldr1 (\x y -> x <> "  " <> y)
+                <=> ( withAttr "help"
-        . (++ ["↑↓:Navigation"])
+                    . txtWrap
-        $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
+                    . T.pack
-        )
+                    . foldr1 (\x y -> x <> "  " <> y)
+                    . (++ ["↑↓:Navigation"])
+                    $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
+                    )
 
  where
+  logDialog = case mproc of
+    Nothing -> emptyWidget
+    Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine
+    Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ ""
   renderItem b ListResult {..} =
     let marks = if
           | lSet       -> (withAttr "set" $ str "✔✔")
@@ -121,7 +151,7 @@ minHSize :: Int -> Widget n -> Widget n
 minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
 
 
-app :: App AppState e String
+app :: App AppState MyAppEvent String
 app = App { appDraw         = \st -> [ui st]
           , appHandleEvent  = eventHandler
           , appStartEvent   = return
@@ -152,19 +182,33 @@ dimAttributes = attrMap
 
 
 
-eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
+eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState)
 eventHandler st (VtyEvent (Vty.EvResize _               _)) = continue st
 eventHandler st (VtyEvent (Vty.EvKey    (Vty.KChar 'q') _)) = halt st
 eventHandler st (VtyEvent (Vty.EvKey    Vty.KEsc        _)) = halt st
 eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
-  continue (AppState (listMoveUp lr) dls pfreq)
+  continue (AppState (listMoveUp lr) dls pfreq mproc)
 eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
-  continue (AppState (listMoveDown lr) dls pfreq)
+  continue (AppState (listMoveDown lr) dls pfreq mproc)
 eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
   case find (\(c', _, _) -> c' == c) keyHandlers of
     Nothing              -> continue as
     Just (_, _, handler) -> handler as
-eventHandler st _ = continue st
+eventHandler st (AppEvent (StartProc str')) = continue st
+  { mproc = Just SubProcess { procName = str'
+                            , exited   = Nothing
+                            , procId   = Nothing
+                            , logLine  = Nothing
+                            }
+  }
+eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) =
+  continue st { mproc = Just sp { procId = Just pid } }
+eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) =
+  continue st { mproc = Just sp { exited = Just exited, procId = Nothing } }
+eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) =
+  continue st { mproc = Just sp { logLine = Just bs } }
+eventHandler st (AppEvent _) = error "noes" -- TODO
+eventHandler st _             = continue st
 
 
 -- | Suspend the current UI and run an IO action in terminal. If the
@@ -174,19 +218,18 @@ withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
              -> EventM n (Next AppState)
 withIOAction action as = case listSelectedElement (lr as) of
   Nothing      -> continue as
-  Just (ix, e) -> suspendAndResume $ do
+  Just (ix, e) -> do
-    action as (ix, e) >>= \case
+    liftIO $ forkIO $ void $ action as (ix, e)
-      Left  err -> putStrLn $ ("Error: " <> err)
+    continue as
-      Right _   -> putStrLn "Success"
+    -- apps <- (fmap . fmap)
-    apps <- (fmap . fmap)
+      -- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
-      (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
+      -- $ getAppState Nothing (pfreq as)
-      $ getAppState Nothing (pfreq as)
+    -- case apps of
-    case apps of
+      -- Right nas -> do
-      Right nas -> do
+        -- putStrLn "Press enter to continue"
-        putStrLn "Press enter to continue"
+        -- _ <- getLine
-        _ <- getLine
+        -- pure nas
-        pure nas
+      -- Left err -> throwIO $ userError err
-      Left err -> throwIO $ userError err
 
 
 install' :: AppState -> (Int, ListResult) -> IO (Either String ())
@@ -302,12 +345,13 @@ settings' :: IORef Settings
 settings' = unsafePerformIO $ do
   dirs <- getDirs
   newIORef Settings { cache      = True
-                     , noVerify   = False
+                    , noVerify   = False
-                     , keepDirs   = Never
+                    , keepDirs   = Never
-                     , downloader = Curl
+                    , downloader = Curl
-                     , verbose    = False
+                    , verbose    = False
-                     , ..
+                    , execCb     = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'")
-                     }
+                    , ..
+                    }
 
 
 logger' :: IORef LoggerConfig
@@ -321,16 +365,22 @@ logger' = unsafePerformIO
 
 
 brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
-brickMain s muri l av pfreq' = do
+brickMain _ muri _ av pfreq' = do
   writeIORef uri'      muri
-  writeIORef settings' s
+  s <- readIORef settings'
   -- logger interpreter
-  writeIORef logger'   l
+  -- writeIORef logger'   l
+  l <- readIORef logger'
   let runLogger = myLoggerT l
 
   eApps <- getAppState (Just av) pfreq'
   case eApps of
-    Right as -> defaultMain app (selectLatest as) $> ()
+    Right as -> do
+      eventChan <- newBChan 1000
+      let builder = Vty.mkVty Vty.defaultConfig
+      initialVty <- builder
+      writeIORef settings' s{ execCb = brickExecCb eventChan }
+      customMain initialVty builder (Just eventChan) app (selectLatest as) $> ()
     Left  e  -> do
       runLogger ($(logError) [i|Error building app state: #{show e}|])
       exitWith $ ExitFailure 2
@@ -359,8 +409,25 @@ getAppState mg pfreq' = do
         dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
 
         lV <- lift $ listVersions dls Nothing Nothing pfreq'
-        pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
+        pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing)
 
   case r of
     VRight a -> pure $ Right a
     VLeft  e -> pure $ Left [i|#{e}|]
+
+
+brickExecCb :: BChan MyAppEvent -> ExecCb
+brickExecCb chan _ fileFd stdoutRead pState lfile = do
+  liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb"
+  writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile)
+  readLineTilEOF lineAction stdoutRead
+  takeMVar pState >>= \case
+    PExited e@(Left _) -> writeBChan chan (EndProc e)
+    _ -> error "no"
+ where
+   lineAction bs = do
+     void $ SPIB.fdWrite fileFd (bs <> "\n")
+     error "blah"
+     writeBChan chan (LogLine bs)
+
+

app/ghcup/Main.hs

@@ -831,7 +831,7 @@ toSettings Options {..} = do
       downloader = optsDownloader
       verbose    = optVerbose
   dirs <- getDirs
-  pure $ Settings { .. }
+  pure $ Settings { execCb     = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..}
 
 
 upgradeOptsP :: Parser UpgradeOpts

bootstrap-haskell

@@ -59,7 +59,7 @@ _done() {
 download_ghcup() {
 	_plat="$(uname -s)"
 	_arch=$(uname -m)
-	_ghver="0.1.8"
+	_ghver="0.1.10"
 	_base_url="https://downloads.haskell.org/~ghcup"
 
     case "${_plat}" in

ghcup-0.0.2.yaml

@@ -1188,6 +1188,11 @@ ghcupDownloads:
             unknown_versioning: *ghc-8102-32-deb9
           Linux_UnknownLinux:
             unknown_versioning: *ghc-8102-32-deb9
+          Linux_Alpine:
+            unknown_versioning:
+              dlUri: https://files.hasufell.de/ghc/ghc-8.10.2-i386-alpine-linux.tar.xz
+              dlSubdir: ghc-8.10.2
+              dlHash: 9ee1cf1e85e9536088b3c9e80e975074e525ea378cd4eb156071bbc4b7b38327
   Cabal:
     2.4.1.0:
       viTags: []
@@ -1300,25 +1305,25 @@ ghcupDownloads:
       viArch:
         A_64:
           Linux_Ubuntu:
-            unknown_versioning: &cabal-3400rc1-trusty
+            unknown_versioning: &cabal-3400rc1-ubuntu
-              dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc1-bootstrapped/cabal-install-3.4.0.0-x86_64-trusty-linux-bootstrapped.tar.xz
+              dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz
-              dlHash: 553ce7e6ab6e375d4a1e437a76eaab0bb418983804d2da13da1f634707e1015a
+              dlHash: 4a693eeacf91993d639b0296a366af7aec6899992352595835f7671e5adef4c6
           Linux_Alpine:
             unknown_versioning:
-              dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc1-bootstrapped/cabal-install-3.4.0.0-x86_64-alpine-3.11.6-linux-bootstrapped.tar.xz
+              dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-alpine-3.11.6-static-noofd.tar.xz
-              dlHash: 7e030563242036975b37be707e43d9ba53df6e41ccb68faf9bf879cbf41abb47
+              dlHash: 143160e1768c9c21bad613f720a37aad34051f41fb3473f5f28c030f9ccb7aca
           Linux_UnknownLinux:
-            unknown_versioning: *cabal-3400rc1-trusty
+            unknown_versioning: *cabal-3400rc1-ubuntu
           Darwin:
             unknown_versioning:
-              dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc1-bootstrapped/cabal-install-3.4.0.0-x86_64-sierra-darwin-bootstrapped.tar.xz
+              dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-darwin-sierra.tar.xz
-              dlHash: 755d32757b91e00e535fc601208ecd11567dbc4d832ae3bf8ce24eaba795aa1d
+              dlHash: 98e362a57c3b5c1a76f75ede2c2a7c29439902a3e21c3e4f8dcd701e276b164f
           FreeBSD:
             unknown_versioning:
-              dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc1-bootstrapped/cabal-install-3.4.0.0-amd64-unknown-freebsd-bootstrapped.tar.xz
+              dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-amd64-freebsd-12.1-release.tar.xz
-              dlHash: 8660f588366355ad4487f7a2e81f31ecb24e15d168d31e227d43d5618a2948d0
+              dlHash: 0035cc5d35db15d254037a9448697e1daff0a6d21b12c8d43d72522c82cc7319
   GHCup:
-    0.1.9:
+    0.1.10:
       viTags:
       - Recommended
       - Latest
@@ -1328,22 +1333,22 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/x86_64-linux-ghcup-0.1.9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-linux-ghcup-0.1.10
-              dlHash: d779ada6156b08da21e40c5bf218ec21d1308d5a9e48f7b9533f56b5d063a41c
+              dlHash: 87661bd127f857b990174ac8d96ad4bd629865306b2058c8cc64d3b36ed317c9
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/x86_64-apple-darwin-ghcup-0.1.9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-apple-darwin-ghcup-0.1.10
-              dlHash: 58ad3bbdb9cbbc7599364c39013bd25394b2cc123645c91fea9dd10c1198d035
+              dlHash: e71666fde6a7700f307e1a55720859d3a042fe27c68ff32f3d1181f4436b7391
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/x86_64-portbld-freebsd-ghcup-0.1.9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-portbld-freebsd-ghcup-0.1.10
-              dlHash: 5fca520307d9d888b4536c394fafea590104a1f4fb5d5fb5a9f738ee7b473dd9
+              dlHash: b5ef1b0454f1a9c5a62b378c1e9c48c2b794d64a22086adf482b064dfb34e68d
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/i386-linux-ghcup-0.1.9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/i386-linux-ghcup-0.1.10
-              dlHash: ad7faf32665d19ced5dc636c0a0c1b14995c530fbd26ca88705a08498b572145
+              dlHash: 50ac43199b64bc0724400b0a3db674bef3ec53cf6d41acc04a2c4ca8557e534f
           Linux_Alpine:
             unknown_versioning: *ghcup-32

ghcup.cabal

@@ -364,6 +364,7 @@ executable ghcup
     , table-layout
     , template-haskell
     , text
+    , unix-bytestring
     , uri-bytestring
     , utf8-string
     , versions

lib/GHCup.hs

@@ -154,7 +154,6 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
     lEM $ execLogged "./configure"
                               False
                               (["--prefix=" <> toFilePath inst] ++ alpineArgs)
-                              [rel|ghc-configure|]
                               (Just path)
                               Nothing
     lEM $ make ["install"] (Just path)
@@ -275,10 +274,12 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
     let cabalFile = [rel|cabal|]
     liftIO $ createDirRecursive newDirPerms inst
     destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
+    let destPath = inst </> destFileName
     handleIO (throwE . CopyError . show) $ liftIO $ copyFile
       (path </> cabalFile)
-      (inst </> destFileName)
+      (destPath)
       Overwrite
+    lift $ chmod_777 destPath
 
 
 -- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
@@ -855,7 +856,6 @@ Stage1Only = YES|]
              )
           ++ fmap E.encodeUtf8 aargs
           )
-          [rel|ghc-conf|]
           (Just workdir)
           (Just (("GHC", toFilePath bghcPath) : cEnv))
       | otherwise -> do
@@ -871,7 +871,6 @@ Stage1Only = YES|]
              )
           ++ fmap E.encodeUtf8 aargs
           )
-          [rel|ghc-conf|]
           (Just workdir)
           (Just cEnv)
 
@@ -1029,7 +1028,6 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
     lEM $ execLogged "./bootstrap.sh"
                               False
                               (maybe [] (\j -> ["-j", fS (show j)]) jobs)
-                              [rel|cabal-bootstrap|]
                               (Just workdir)
                               (Just newEnv)
     pure $ (tmp </> [rel|bin/cabal|])
@@ -1075,17 +1073,12 @@ upgradeGHCup dls mtarget force pfreq = do
   tmp   <- lift withGHCupTmpDir
   let fn = [rel|ghcup|]
   p <- liftE $ download dli tmp (Just fn)
-  let fileMode' =
-        newFilePerms
-          `unionFileModes` ownerExecuteMode
-          `unionFileModes` groupExecuteMode
-          `unionFileModes` otherExecuteMode
   let fullDest = fromMaybe (binDir </> fn) mtarget
   liftIO $ hideError NoSuchThing $ deleteFile fullDest
   handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
                                                            fullDest
                                                            Overwrite
-  liftIO $ setFileMode (toFilePath fullDest) fileMode'
+  lift $ chmod_777 fullDest
   pure latestVer
 
 

lib/GHCup/Download/IOStreams.hs

@@ -13,6 +13,7 @@ module GHCup.Download.IOStreams where
 
 import           GHCup.Download.Utils
 import           GHCup.Errors
+import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.File

lib/GHCup/Types.hs

@@ -1,6 +1,10 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 {-|
 Module      : GHCup.Types
@@ -13,11 +17,14 @@ Portability : POSIX
 -}
 module GHCup.Types where
 
+import           Control.Concurrent.MVar
+import           Data.ByteString                ( ByteString )
 import           Data.Map.Strict                ( Map )
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           HPath
 import           URI.ByteString
+import           System.Posix.Types
 
 import qualified GHC.Generics                  as GHC
 
@@ -163,6 +170,27 @@ data URLSource = GHCupURL
                deriving Show
 
 
+data ProcessError = NonZeroExit Int ByteString [ByteString]
+                  | PTerminated ByteString [ByteString]
+                  | PStopped ByteString [ByteString]
+                  | NoSuchPid ByteString [ByteString]
+                  deriving (Eq, Show)
+
+data ProcState = PRunning ProcessID
+               | PExited (Either ProcessError ())
+  deriving Eq
+
+type ExecCb =    Bool       -- verbose
+              -> Fd         -- log file fd
+              -> Fd         -- input fd to read from
+              -> MVar ProcState  -- state of the producing process
+              -> ByteString -- log filename
+              -> IO ()
+
+instance Show ExecCb where
+  show _ = "**ExecCb**"
+
+
 data Settings = Settings
   { -- set by user
     cache      :: Bool
@@ -173,6 +201,7 @@ data Settings = Settings
 
     -- set on app start
   , dirs       :: Dirs
+  , execCb     :: ExecCb
   }
   deriving Show
 

lib/GHCup/Utils.hs

@@ -550,7 +550,7 @@ make args workdir = do
   spaths    <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
   has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
   let mymake = if has_gmake then "gmake" else "make"
-  execLogged mymake True args [rel|ghc-make|] workdir Nothing
+  execLogged mymake True args workdir Nothing
 
 
 -- | Try to apply patches in order. Fails with 'PatchFailed'

lib/GHCup/Utils/File.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 {-|
 Module      : GHCup.Utils.File
@@ -25,6 +26,7 @@ import           Control.Concurrent.Async
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.State.Strict
 import           Data.ByteString                ( ByteString )
@@ -33,6 +35,7 @@ import           Data.Functor
 import           Data.IORef
 import           Data.Maybe
 import           Data.Sequence                  ( Seq, (|>) )
+import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Void
 import           Data.Word8
@@ -46,6 +49,7 @@ import           System.IO.Error
 import           System.Posix.Directory.ByteString
 import           System.Posix.FD               as FD
 import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Files.ByteString
 import           System.Posix.Foreign           ( oExcl )
 import "unix"    System.Posix.IO.ByteString
                                          hiding ( openFd )
@@ -68,14 +72,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
                                                as SPIB
 
 
-
-data ProcessError = NonZeroExit Int ByteString [ByteString]
-                  | PTerminated ByteString [ByteString]
-                  | PStopped ByteString [ByteString]
-                  | NoSuchPid ByteString [ByteString]
-                  deriving Show
-
-
 data CapturedProcess = CapturedProcess
   { _exitCode :: ExitCode
   , _stdOut   :: ByteString
@@ -117,30 +113,31 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
            => ByteString       -- ^ thing to execute
            -> Bool             -- ^ whether to search PATH for the thing
            -> [ByteString]     -- ^ args for the thing
-           -> Path Rel         -- ^ log filename
            -> Maybe (Path Abs) -- ^ optionally chdir into this
            -> Maybe [(ByteString, ByteString)] -- ^ optional environment
            -> m (Either ProcessError ())
-execLogged exe spath args lfile chdir env = do
+execLogged exe spath args chdir env = do
   Settings {dirs = Dirs {..}, ..} <- ask
-  logfile       <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
+  logfile       <- (logsDir </>) <$> parseRel (lfile <> ".log")
   liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
                    closeFd
-                   (action verbose)
+                   (action verbose execCb)
  where
-  action verbose fd = do
+  lfile = fromMaybe exe $ BS.stripPrefix "./" exe
+
+  action verbose cb fd = do
     actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
       -- start the thread that logs to stdout
-      pState <- newEmptyMVar
+      pState  <- newEmptyMVar
-      done   <- newEmptyMVar
+      done    <- newEmptyMVar
+      liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1"
       void
         $ forkIO
         $ EX.handle (\(_ :: IOException) -> pure ())
         $ flip EX.finally (putMVar done ())
-        $ (if verbose
+        $ (do
-            then tee fd stdoutRead
+            liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
-            else printToRegion fd stdoutRead 6 pState
+            cb verbose fd stdoutRead pState lfile)
-          )
 
       -- fork the subprocess
       pid <- SPPB.forkProcess $ do
@@ -153,115 +150,57 @@ execLogged exe spath args lfile chdir env = do
         maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
         void $ SPPB.executeFile exe spath args env
 
+      putMVar pState (PRunning pid)
+
       closeFd stdoutWrite
 
       -- wait for the subprocess to finish
       e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
-      putMVar pState (either (const False) (const True) e)
+      void $ swapMVar pState (PExited e)
 
       void $ race (takeMVar done) (threadDelay (1000000 * 3))
       closeFd stdoutRead
 
       pure e
 
-  tee :: Fd -> Fd -> IO ()
-  tee fileFd fdIn = readTilEOF lineAction fdIn
 
-   where
+readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
-    lineAction :: ByteString -> IO ()
+readLineTilEOF ~action' fd' = go mempty
-    lineAction bs' = do
+ where
-      void $ SPIB.fdWrite fileFd (bs' <> "\n")
+  go bs' = do
-      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
+    (bs, rest, eof) <- readLine fd' bs'
+    if eof
+       then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
+       else (void $ action' bs) >> go rest
 
-  -- Reads fdIn and logs the output in a continous scrolling area
-  -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
-  printToRegion fileFd fdIn size pState = do
-    void $ displayConsoleRegions $ do
-      rs <-
-        liftIO
-        . fmap Sq.fromList
-        . sequence
-        . replicate size
-        . openConsoleRegion
-        $ Linear
-      flip runStateT mempty
-        $ handle
-            (\(ex :: SomeException) -> do
-              ps <- liftIO $ takeMVar pState
-              when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
-              throw ex
-            )
-        $ readTilEOF (lineAction rs) fdIn
 
-   where
+-- Consecutively read from Fd in 512 chunks until we hit
-    -- action to perform line by line
+-- newline or EOF.
-    -- TODO: do this with vty for efficiency
+readLine :: MonadIO m
-    lineAction :: (MonadMask m, MonadIO m)
+         => Fd          -- ^ input file descriptor
-               => Seq ConsoleRegion
+         -> ByteString  -- ^ rest buffer (read across newline)
-               -> ByteString
+         -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
-               -> StateT (Seq ByteString) m ()
+readLine fd = \inBs -> go inBs
-    lineAction rs = \bs' -> do
+ where
-      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
+  go inBs = do
-      modify (swapRegs bs')
+    -- if buffer is not empty, process it first
-      regs <- get
+    mbs <- if BS.length inBs == 0
-      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
+             -- otherwise attempt read
-        w <- consoleWidth
+             then liftIO
-        return
+                  $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
-          . T.pack
+                  $ fmap Just
-          . color Blue
+                  $ SPIB.fdRead fd 512
-          . T.unpack
+             else pure $ Just inBs
-          . decUTF8Safe
+    case mbs of
-          . trim w
+      Nothing -> pure ("", "", True)
-          . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
+      Just bs -> do
-          $ bs
+        -- split on newline
+        let (line, rest) = BS.span (/= _lf) bs
+        if
+          | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
+          -- if rest is empty, then there was no newline, process further
+          | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
 
-    swapRegs :: a -> Seq a -> Seq a
-    swapRegs bs = \regs -> if
-      | Sq.length regs < size -> regs |> bs
-      | otherwise             -> Sq.drop 1 regs |> bs
-
-    -- trim output line to terminal width
-    trim :: Int -> ByteString -> ByteString
-    trim w = \bs -> if
-      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
-      | otherwise                 -> bs
-
-  -- Consecutively read from Fd in 512 chunks until we hit
-  -- newline or EOF.
-  readLine :: MonadIO m
-           => Fd          -- ^ input file descriptor
-           -> ByteString  -- ^ rest buffer (read across newline)
-           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
-  readLine fd = \inBs -> go inBs
-   where
-    go inBs = do
-      -- if buffer is not empty, process it first
-      mbs <- if BS.length inBs == 0
-               -- otherwise attempt read
-               then liftIO
-                    $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
-                    $ fmap Just
-                    $ SPIB.fdRead fd 512
-               else pure $ Just inBs
-      case mbs of
-        Nothing -> pure ("", "", True)
-        Just bs -> do
-          -- split on newline
-          let (line, rest) = BS.span (/= _lf) bs
-          if
-            | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-            -- if rest is empty, then there was no newline, process further
-            | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
-
-  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
-  readTilEOF ~action' fd' = go mempty
-   where
-    go bs' = do
-      (bs, rest, eof) <- readLine fd' bs'
-      if eof
-         then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
-         else (void $ action' bs) >> go rest
 
 
 -- | Capture the stdout and stderr of the given action, which
@@ -375,7 +314,7 @@ toProcessError :: ByteString
                -> Maybe ProcessStatus
                -> Either ProcessError ()
 toProcessError exe args mps = case mps of
-  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
+  Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
   Just (SPPB.Exited ExitSuccess    ) -> Right ()
   Just (Terminated _ _             ) -> Left $ PTerminated exe args
   Just (Stopped _                  ) -> Left $ PStopped exe args
@@ -434,3 +373,88 @@ isBrokenSymlink p =
     $ do
         _ <- canonicalizePath p
         pure False
+
+
+chmod_777 :: (MonadLogger m, MonadIO m) => Path a -> m ()
+chmod_777 (toFilePath -> fp) = do
+  let exe_mode =
+          newFilePerms
+            `unionFileModes` ownerExecuteMode
+            `unionFileModes` groupExecuteMode
+            `unionFileModes` otherExecuteMode
+  $(logDebug) [i|chmod 777 #{fp}|]
+  liftIO $ setFileMode fp exe_mode
+
+
+-- | The default callback for logging/printing on 'execLogged'.
+defExecCb :: ExecCb
+defExecCb verbose fd stdoutRead pState lfile = if verbose
+      then tee fd stdoutRead
+      else printToRegion fd stdoutRead 6
+ where
+  tee :: Fd -> Fd -> IO ()
+  tee fileFd fdIn = readLineTilEOF lineAction fdIn
+
+   where
+    lineAction :: ByteString -> IO ()
+    lineAction bs' = do
+      void $ SPIB.fdWrite fileFd (bs' <> "\n")
+      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
+
+  -- Reads fdIn and logs the output in a continous scrolling area
+  -- of 'size' terminal lines. Also writes to a log file.
+  printToRegion :: Fd -> Fd -> Int -> IO ()
+  printToRegion fileFd fdIn size = do
+    void $ displayConsoleRegions $ do
+      rs <-
+        liftIO
+        . fmap Sq.fromList
+        . sequence
+        . replicate size
+        . openConsoleRegion
+        $ Linear
+      flip runStateT mempty
+        $ handle
+            (\(ex :: SomeException) -> do
+              let closeEventually = readMVar pState >>= \case
+                    PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion)
+                    _ -> threadDelay 500 >> closeEventually
+              void $ liftIO $ race closeEventually (threadDelay (1000000 * 3))
+              throw ex
+            )
+        $ readLineTilEOF (lineAction rs) fdIn
+
+   where
+    -- action to perform line by line
+    -- TODO: do this with vty for efficiency
+    lineAction :: (MonadMask m, MonadIO m)
+               => Seq ConsoleRegion
+               -> ByteString
+               -> StateT (Seq ByteString) m ()
+    lineAction rs = \bs' -> do
+      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
+      modify (swapRegs bs')
+      regs <- get
+      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
+        w <- consoleWidth
+        return
+          . T.pack
+          . color Blue
+          . T.unpack
+          . decUTF8Safe
+          . trim w
+          . (\b -> "[ " <> lfile <> " ] " <> b)
+          $ bs
+
+    swapRegs :: a -> Seq a -> Seq a
+    swapRegs bs = \regs -> if
+      | Sq.length regs < size -> regs |> bs
+      | otherwise             -> Sq.drop 1 regs |> bs
+
+    -- trim output line to terminal width
+    trim :: Int -> ByteString -> ByteString
+    trim w = \bs -> if
+      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
+      | otherwise                 -> bs
+
+