Lala

Use 8.10.2 in gitlab CI
Add GHC-8.10.2 for alpine 32big
2020-08-27 23:39:47 +02:00 · 2020-08-15 23:54:50 +02:00 · 2020-08-15 23:34:05 +02:00 · 2020-08-14 22:27:05 +02:00 · 2020-08-14 22:07:39 +02:00 · 2020-08-14 21:49:01 +02:00
14 changed files with 354 additions and 199 deletions
--- a/.gitlab-ci.yml
+++ b/.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

--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
 # Revision history for ghcup

+## 0.1.10 -- 2020-08-14
+
+* Show stray Cabals (useful for pre-releases or compiled ones)
+
 ## 0.1.9 -- 2020-08-14

 * Fix bug when uninstalling all cabal versions
--- a/app/ghcup-gen/Validate.hs
+++ b/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 ())
--- a/app/ghcup/BrickMain.hs
+++ b/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
-  , dls :: GHCupDownloads
+    lr    :: LR
+  , 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
-    $ ( withBorderStyle unicode
-      $ borderWithLabel (str "GHCup")
-      $ (center $ renderList renderItem True lr)
-      )
-    )
-    <=> ( withAttr "help"
-        . txtWrap
-        . T.pack
-        . foldr1 (\x y -> x <> "  " <> y)
-        . (++ ["↑↓:Navigation"])
-        $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
-        )
+  case mproc of
+    Just _ -> logDialog
+    Nothing ->
+              ( padBottom Max
+                $ ( withBorderStyle unicode
+                  $ borderWithLabel (str "GHCup")
+                  $ (center $ renderList renderItem True lr)
+                  )
+                )
+                <=> ( withAttr "help"
+                    . txtWrap
+                    . 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
-    action as (ix, e) >>= \case
-      Left  err -> putStrLn $ ("Error: " <> err)
-      Right _   -> putStrLn "Success"
-    apps <- (fmap . fmap)
-      (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
-      $ getAppState Nothing (pfreq as)
-    case apps of
-      Right nas -> do
-        putStrLn "Press enter to continue"
-        _ <- getLine
-        pure nas
-      Left err -> throwIO $ userError err
+  Just (ix, e) -> do
+    liftIO $ forkIO $ void $ action as (ix, e)
+    continue as
+    -- apps <- (fmap . fmap)
+      -- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
+      -- $ getAppState Nothing (pfreq as)
+    -- case apps of
+      -- Right nas -> do
+        -- putStrLn "Press enter to continue"
+        -- _ <- getLine
+        -- pure nas
+      -- 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
-                     , keepDirs   = Never
-                     , downloader = Curl
-                     , verbose    = False
-                     , ..
-                     }
+                    , noVerify   = False
+                    , keepDirs   = Never
+                    , downloader = Curl
+                    , 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)
+
+
--- a/app/ghcup/Main.hs
+++ b/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
--- a/2
+++ b/2
@@ -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
--- a/ghcup-0.0.2.yaml
+++ b/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
-              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
-              dlHash: 553ce7e6ab6e375d4a1e437a76eaab0bb418983804d2da13da1f634707e1015a
+            unknown_versioning: &cabal-3400rc1-ubuntu
+              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: 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
-              dlHash: 7e030563242036975b37be707e43d9ba53df6e41ccb68faf9bf879cbf41abb47
+              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: 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
-              dlHash: 755d32757b91e00e535fc601208ecd11567dbc4d832ae3bf8ce24eaba795aa1d
+              dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-darwin-sierra.tar.xz
+              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
-              dlHash: 8660f588366355ad4487f7a2e81f31ecb24e15d168d31e227d43d5618a2948d0
+              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: 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
-              dlHash: d779ada6156b08da21e40c5bf218ec21d1308d5a9e48f7b9533f56b5d063a41c
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-linux-ghcup-0.1.10
+              dlHash: 87661bd127f857b990174ac8d96ad4bd629865306b2058c8cc64d3b36ed317c9
          Darwin:
            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/x86_64-apple-darwin-ghcup-0.1.9
-              dlHash: 58ad3bbdb9cbbc7599364c39013bd25394b2cc123645c91fea9dd10c1198d035
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-apple-darwin-ghcup-0.1.10
+              dlHash: e71666fde6a7700f307e1a55720859d3a042fe27c68ff32f3d1181f4436b7391
          FreeBSD:
            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.9/x86_64-portbld-freebsd-ghcup-0.1.9
-              dlHash: 5fca520307d9d888b4536c394fafea590104a1f4fb5d5fb5a9f738ee7b473dd9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-portbld-freebsd-ghcup-0.1.10
+              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
-              dlHash: ad7faf32665d19ced5dc636c0a0c1b14995c530fbd26ca88705a08498b572145
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.10/i386-linux-ghcup-0.1.10
+              dlHash: 50ac43199b64bc0724400b0a3db674bef3ec53cf6d41acc04a2c4ca8557e534f
          Linux_Alpine:
            unknown_versioning: *ghcup-32
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.9
+version:            0.1.10
 synopsis:           ghc toolchain installer as an exe/library
 description:
  A rewrite of the shell script ghcup, for providing
@@ -364,6 +364,7 @@ executable ghcup
    , table-layout
    , template-haskell
    , text
+    , unix-bytestring
    , uri-bytestring
    , utf8-string
    , versions
--- a/lib/GHCup.hs
+++ b/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
@@ -506,6 +507,9 @@ listVersions av lt criteria pfreq = do
        GHC -> do
          slr <- strayGHCs avTools
          pure $ (sort (slr ++ lr))
+        Cabal -> do
+          slr <- strayCabals avTools
+          pure $ (sort (slr ++ lr))
        _ -> pure lr
    Nothing -> do
      ghcvers   <- listVersions av (Just GHC) criteria pfreq
@@ -554,6 +558,33 @@ listVersions av lt criteria pfreq = do
          [i|Could not parse version of stray directory #{toFilePath e}|]
        pure Nothing

+  strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
+            => Map.Map Version [Tag]
+            -> m [ListResult]
+  strayCabals avTools = do
+    cabals <- getInstalledCabals
+    fmap catMaybes $ forM cabals $ \case
+      Right ver ->
+        case Map.lookup ver avTools of
+          Just _  -> pure Nothing
+          Nothing -> do
+            lSet    <- fmap (maybe False (== ver)) $ cabalSet
+            pure $ Just $ ListResult
+              { lTool      = Cabal
+              , lVer       = ver
+              , lCross     = Nothing
+              , lTag       = []
+              , lInstalled = True
+              , lStray     = maybe True (const False) (Map.lookup ver avTools)
+              , lNoBindist = False
+              , fromSrc    = False -- actually, we don't know :>
+              , ..
+              }
+      Left e -> do
+        $(logWarn)
+          [i|Could not parse version of stray directory #{toFilePath e}|]
+        pure Nothing
+
  -- NOTE: this are not cross ones, because no bindists
  toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
  toListResult t (v, tags) = case t of
@@ -825,7 +856,6 @@ Stage1Only = YES|]
             )
          ++ fmap E.encodeUtf8 aargs
          )
-          [rel|ghc-conf|]
          (Just workdir)
          (Just (("GHC", toFilePath bghcPath) : cEnv))
      | otherwise -> do
@@ -841,7 +871,6 @@ Stage1Only = YES|]
             )
          ++ fmap E.encodeUtf8 aargs
          )
-          [rel|ghc-conf|]
          (Just workdir)
          (Just cEnv)

@@ -999,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|])
@@ -1045,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


--- a/lib/GHCup/Download/IOStreams.hs
+++ b/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
--- a/lib/GHCup/Types.hs
+++ b/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

--- a/lib/GHCup/Utils.hs
+++ b/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'
--- a/lib/GHCup/Utils/File.hs
+++ b/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
-      done   <- newEmptyMVar
+      pState  <- 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
-            then tee fd stdoutRead
-            else printToRegion fd stdoutRead 6 pState
-          )
+        $ (do
+            liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
+            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
-    lineAction :: ByteString -> IO ()
-    lineAction bs' = do
-      void $ SPIB.fdWrite fileFd (bs' <> "\n")
-      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
+readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
+readLineTilEOF ~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

-  -- 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
-    -- 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 -> "[ " <> toFilePath lfile <> " ] " <> b)
-          $ 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

-    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
+
+
--- a/lib/GHCup/Version.hs
+++ b/lib/GHCup/Version.hs
@@ -26,7 +26,7 @@ ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]

 -- | The current ghcup version.
 ghcUpVer :: PVP
-ghcUpVer = [pver|0.1.9|]
+ghcUpVer = [pver|0.1.10|]

 -- | ghcup version as numeric string.
 numericVer :: String
Author	SHA1	Message	Date
Julian Ospald	14168a41fe	Lala	2020-08-27 23:39:47 +02:00
Julian Ospald	6342e8edf0	Use 8.10.2 in gitlab CI	2020-08-15 23:54:50 +02:00
Julian Ospald	bbd8f0c84c	Add GHC-8.10.2 for alpine 32big	2020-08-15 23:34:05 +02:00
Julian Ospald	873c951d6e	Refactor chmod +x	2020-08-14 22:27:05 +02:00
Julian Ospald	d9c864d3c5	Make sure cabal is executable wrt #46	2020-08-14 22:07:39 +02:00
Julian Ospald	4280d7109a	Fix 3.4.0.0-rc1 urls wrt #46	2020-08-14 21:49:01 +02:00
Julian Ospald	c8855c068f	Update version in bootstrap-haskell	2020-08-14 20:36:14 +02:00
Julian Ospald	90503061e9	Add ghcup-0.1.10	2020-08-14 20:22:27 +02:00
Julian Ospald	672ebf6426	Bump version	2020-08-14 16:57:15 +02:00
Julian Ospald	fd76fde23a	Add cabal-3.4.0.0-rc1	2020-08-14 16:54:27 +02:00
Julian Ospald	e24c9a3ffe	Show stray cabals, fixes #45	2020-08-14 16:53:32 +02:00