Lala

README.md

@@ -9,15 +9,11 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
 ## Table of Contents
 
    * [Installation](#installation)
-     * [Simple bootstrap](#simple-bootstrap)
-     * [Manual install](#manual-install)
-     * [Vim integration](#vim-integration)
    * [Usage](#usage)
      * [Manpages](#manpages)
      * [Shell-completion](#shell-completion)
      * [Cross support](#cross-support)
      * [XDG support](#xdg-support)
-     * [Installing custom bindists](#installing-custom-bindists)
    * [Design goals](#design-goals)
    * [How](#how)
    * [Known users](#known-users)
@@ -41,10 +37,6 @@ Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) lik
 export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
 ```
 
-### Vim integration
-
-See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
-
 ## Usage
 
 See `ghcup --help`.
@@ -115,22 +107,6 @@ Then you can control the locations via XDG environment variables as such:
 * `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir
 * `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
 
-### Installing custom bindists
-
-There are a couple of good use cases to install custom bindists:
-
-1. manually built bindists (e.g. with patches)
-  - example: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz" }' 8.10.2-eff`
-2. GHC head CI bindists
-  - example: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head`
-3. DWARF bindists
-  - example: `ghcup -c -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz" }' 8.10.2-dwarf`
-
-Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
-and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
-GHCup always needs to know which version the bindist corresponds to (this is not automatically
-detected).
-
 ## Design goals
 
 1. simplicity

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
@@ -910,7 +910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
 
           -- create ~/.ghcup dir
-          createDirRecursive' baseDir
+          createDirRecursive newDirPerms baseDir
 
           -- logger interpreter
           logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]

bootstrap-haskell

@@ -235,7 +235,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
 						if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
 							echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 							echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
-							echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
+							echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
 						fi
 						break ;;
 					*)

cabal.project

@@ -19,6 +19,6 @@ package ghcup
 constraints: http-io-streams -brotli
 
 package libarchive
-  flags: -system-libarchive
+  flags: +static
 
 allow-newer: base, ghc-prim, template-haskell

ghcup-0.0.2.yaml

@@ -1159,7 +1159,7 @@ ghcupDownloads:
           Linux_Alpine:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-alpine3.10-linux-integer-simple.tar.xz
-              dlSubdir: ghc-8.10.2-x86_64-unknown-linux
+              dlSubdir: ghc-8.10.2
               dlHash: 14d09a508f2a3a11875c140be8e6c5f6982ac5cd448f089ca10b7adc955fec76
           Linux_AmazonLinux:
             unknown_versioning: *ghc-8102-64-centos
@@ -1193,78 +1193,6 @@ ghcupDownloads:
               dlUri: https://files.hasufell.de/ghc/ghc-8.10.2-i386-alpine-linux.tar.xz
               dlSubdir: ghc-8.10.2
               dlHash: 9ee1cf1e85e9536088b3c9e80e975074e525ea378cd4eb156071bbc4b7b38327
-    9.0.1-alpha1:
-      viTags:
-      - Prerelease
-      - base-4.15.0.0
-      viSourceDL:
-        dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-src.tar.xz
-        dlSubdir: ghc-9.0.0.20200821
-        dlHash: 8a3a36a0d770dbe678dbc084c3cc9a426749ac9d695f34fa30dc4da1564be6cb
-      viArch:
-        A_64:
-          Linux_Debian:
-            '9': &ghc-901a1-64-deb9
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-deb9-linux.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: a58b508e5d9f85a5831c7e451766105c4b2188987b3110ac62c8182e3e6ed0f6
-            '10': &ghc-901a1-64-deb10
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-deb10-linux-dwarf.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: 963d4cef71780f24d23cd947d33f61e9ee338f85e2aed06ec588fdb8be339a04
-            unknown_versioning: *ghc-901a1-64-deb9
-          Linux_Ubuntu:
-            unknown_versioning: &ghc-901a1-64-fedora
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-fedora27-linux.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: e6c241d7945fe84e03501c8a9b947a5f50ad489cdf2b6e286d5de76046a8a6f3
-            '16.04': *ghc-901a1-64-deb9
-            '18.04': *ghc-901a1-64-deb9
-          Linux_Mint:
-            unknown_versioning: *ghc-901a1-64-deb10
-          Linux_Fedora:
-            '27': *ghc-901a1-64-fedora
-            unknown_versioning: *ghc-901a1-64-fedora
-          Linux_CentOS:
-            '7': &ghc-901a1-64-centos
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-centos7-linux.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: e9be471727d6753514667781335018be0fed91483bf80da3f24d21c2e49086e9
-            unknown_versioning: *ghc-901a1-64-centos
-          Linux_RedHat:
-            unknown_versioning: *ghc-901a1-64-centos
-          Linux_Alpine:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-alpine3.10-linux-integer-simple.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: 8a73cbcebe8aac004dda4411873b6cd57169af9af74cbeb636d695852da1f10c
-          Linux_AmazonLinux:
-            unknown_versioning: *ghc-901a1-64-centos
-          Linux_UnknownLinux:
-            unknown_versioning: *ghc-901a1-64-fedora
-          Darwin:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-apple-darwin.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: 5bb43fe34997222ae092f3c255d0545dd8ff17409d00f56a356aece9042ace2a
-          FreeBSD:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-x86_64-unknown-freebsd.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: 2cb2763fa59bff4c045b7012170132a7a49f09e4f0f894c5367f990b60c38830
-        A_32:
-          Linux_Debian:
-            '9': &ghc-901a1-32-deb9
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1-alpha1/ghc-9.0.0.20200821-i386-deb9-linux.tar.xz
-              dlSubdir: ghc-9.0.0
-              dlHash: 8b025e0c66bb4e21c050755d4c77b7cea66d0269f00f5206c3cef51861aa360f
-            unknown_versioning: *ghc-901a1-32-deb9
-          Linux_Ubuntu:
-            unknown_versioning: *ghc-901a1-32-deb9
-          Linux_Mint:
-            unknown_versioning: *ghc-901a1-32-deb9
-          Linux_UnknownLinux:
-            unknown_versioning: *ghc-901a1-32-deb9
   Cabal:
     2.4.1.0:
       viTags: []

ghcup.cabal

@@ -112,7 +112,7 @@ common io-streams
   build-depends: io-streams >=1.5
 
 common libarchive
-  build-depends: libarchive >= 3.0.0.0
+  build-depends: libarchive >= 2.2.5.0
 
 common lzma
   build-depends: lzma >=0.0.0.3
@@ -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)
@@ -273,7 +272,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
   installCabal' path inst = do
     lift $ $(logInfo) "Installing cabal"
     let cabalFile = [rel|cabal|]
-    liftIO $ createDirRecursive' inst
+    liftIO $ createDirRecursive newDirPerms inst
     destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
     let destPath = inst </> destFileName
     handleIO (throwE . CopyError . show) $ liftIO $ copyFile
@@ -352,7 +351,7 @@ setGHC ver sghc = do
 
   -- symlink destination
   Settings { dirs = Dirs {..} } <- lift ask
-  liftIO $ createDirRecursive' binDir
+  liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
 
   -- first delete the old symlinks (this fixes compatibility issues
   -- with old ghcup)
@@ -424,7 +423,7 @@ setCabal ver = do
 
   -- symlink destination
   Settings {dirs = Dirs {..}} <- lift ask
-  liftIO $ createDirRecursive' binDir
+  liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
 
   whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
     $ throwE
@@ -857,7 +856,6 @@ Stage1Only = YES|]
              )
           ++ fmap E.encodeUtf8 aargs
           )
-          [rel|ghc-conf|]
           (Just workdir)
           (Just (("GHC", toFilePath bghcPath) : cEnv))
       | otherwise -> do
@@ -873,7 +871,6 @@ Stage1Only = YES|]
              )
           ++ fmap E.encodeUtf8 aargs
           )
-          [rel|ghc-conf|]
           (Just workdir)
           (Just cEnv)
 
@@ -1024,14 +1021,13 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
           ]
 
     tmp <- lift withGHCupTmpDir
-    liftIO $ createDirRecursive' (tmp </> [rel|bin|])
+    liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
     newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
     lift $ $(logDebug) [i|Environment: #{newEnv}|]
 
     lEM $ execLogged "./bootstrap.sh"
                               False
                               (maybe [] (\j -> ["-j", fS (show j)]) jobs)
-                              [rel|cabal-bootstrap|]
                               (Just workdir)
                               (Just newEnv)
     pure $ (tmp </> [rel|bin/cabal|])

lib/GHCup/Download.hs

@@ -226,7 +226,7 @@ getDownloads urlSource = do
           else -- access in less than 5 minutes, re-use file
                liftIO $ readFile json_file
       else do
-        liftIO $ createDirRecursive' cacheDir
+        liftIO $ createDirRecursive newDirPerms cacheDir
         getModTime >>= \case
           Just modTime -> dlWithMod modTime json_file
           Nothing -> do
@@ -330,7 +330,7 @@ download dli dest mfn
   scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
   cp     = do
     -- destination dir must exist
-    liftIO $ createDirRecursive' dest
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
     destFile <- getDestFile
     fromFile <- parseAbs path
     liftIO $ copyFile fromFile destFile Strict
@@ -340,7 +340,7 @@ download dli dest mfn
     lift $ $(logInfo) [i|downloading: #{uri'}|]
 
     -- destination dir must exist
-    liftIO $ createDirRecursive' dest
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
     destFile <- getDestFile
 
     -- download

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

@@ -36,7 +36,7 @@ import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 
 #if !defined(TAR)
-import           Codec.Archive           hiding ( Directory )
+import           Codec.Archive
 #endif
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -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'
@@ -621,25 +621,3 @@ runBuildAction bdir instdir action = do
   when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
     bdir
   pure v
-
-
--- | More permissive version of 'createDirRecursive'. This doesn't
--- error when the destination is a symlink to a directory.
-createDirRecursive' :: Path b -> IO ()
-createDirRecursive' p =
-  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
-    . createDirRecursive newDirPerms
-    $ p
-
- where
-  isSymlinkDir e = do
-    ft <- getFileType p
-    case ft of
-      SymbolicLink -> do
-        rp <- canonicalizePath p
-        rft <- getFileType rp
-        case rft of
-          Directory -> pure ()
-          _ -> throwIO e
-      _ -> throwIO e
-

lib/GHCup/Utils/File.hs

@@ -72,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
@@ -121,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
@@ -157,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
@@ -450,3 +385,76 @@ chmod_777 (toFilePath -> fp) = do
   $(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
+
+

lib/GHCup/Utils/Logger.hs

@@ -15,7 +15,6 @@ Here we define our main logger.
 module GHCup.Utils.Logger where
 
 import           GHCup.Types
-import           GHCup.Utils
 
 import           Control.Monad
 import           Control.Monad.IO.Class
@@ -70,7 +69,7 @@ initGHCupFileLogging context = do
   Settings {dirs = Dirs {..}} <- ask
   let logfile = logsDir </> context
   liftIO $ do
-    createDirRecursive' logsDir
+    createDirRecursive newDirPerms logsDir
     hideError doesNotExistErrorType $ deleteFile logfile
     createRegularFile newFilePerms logfile
     pure logfile