Lala

2020-08-19 19:24:05 +02:00
parent 6342e8edf0
commit 14168a41fe
9 changed files with 269 additions and 166 deletions
--- 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)
@@ -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)

@@ -1031,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|])
--- 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
@@ -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
-      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
@@ -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
-    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
@@ -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
+
+