Fix bug in installCabalBin

It would die on newlines due to empty String blindness.
Also make sure takeMVar does not block.

.gitlab/script/ghcup_version.sh

@@ -44,12 +44,6 @@ ghcup-gen check -f ghcup-${JSON_VERSION}.json
 
 eghcup --numeric-version
 
-# TODO: rm once we have tarballs
-if [ "${OS}"  = "FREEBSD" ] ; then
-	GHC_VERSION=8.6.3
-	CABAL_VERSION=2.4.1.0
-fi
-
 eghcup install ${GHC_VERSION}
 eghcup set ${GHC_VERSION}
 eghcup install-cabal ${CABAL_VERSION}

CHANGELOG.md

@@ -1,5 +1,10 @@
 # Revision history for ghcup
 
+## 0.1.8 -- 2020-07-21
+
+* Fix bug in logging thread dying on newlines
+* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
+
 ## 0.1.7 -- 2020-07-20
 
 * Fix a bug in libarchive not unpacking some uncleanly packed bindists

app/ghcup/Main.hs

@@ -38,6 +38,7 @@ import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
+import           Data.Aeson                     ( eitherDecode )
 import           Data.Bifunctor
 import           Data.Char
 import           Data.Either
@@ -68,6 +69,7 @@ import           URI.ByteString
 
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.ByteString.Lazy.UTF8     as BLU
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
@@ -119,6 +121,7 @@ data InstallCommand = InstallGHC InstallOptions
 data InstallOptions = InstallOptions
   { instVer      :: Maybe ToolVersion
   , instPlatform :: Maybe PlatformRequest
+  , instBindist  :: Maybe DownloadInfo
   }
 
 data SetCommand = SetGHC SetOptions
@@ -405,7 +408,7 @@ installParser =
 
 installOpts :: Parser InstallOptions
 installOpts =
-  (flip InstallOptions)
+  (\p u v -> InstallOptions v p u)
     <$> (optional
           (option
             (eitherReader platformParser)
@@ -417,6 +420,17 @@ installOpts =
             )
           )
         )
+    <*> (optional
+          (option
+            (eitherReader bindistParser)
+            (  short 'u'
+            <> long "url"
+            <> metavar "BINDIST_URL"
+            <> help
+                 "Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
+            )
+          )
+        )
     <*> optional toolVersionArgument
 
 
@@ -800,6 +814,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
         pure v
 
 
+bindistParser :: String -> Either String DownloadInfo
+bindistParser = eitherDecode . BLU.fromString
 
 
 toSettings :: Options -> Settings
@@ -1047,7 +1063,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let installGHC InstallOptions{..} =
                   (runInstTool $ do
                       v <- liftE $ fromVersion dls instVer GHC
-                      liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
+                      case instBindist of
+                        Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
+                        Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
                     )
                     >>= \case
                           VRight _ -> do
@@ -1081,7 +1099,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let installCabal InstallOptions{..} =
                 (runInstTool $ do
                     v <- liftE $ fromVersion dls instVer Cabal
-                    liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
+                    case instBindist of
+                      Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
+                      Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
                   )
                   >>= \case
                         VRight _ -> do

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.7
+version:            0.1.8
 synopsis:           ghc toolchain installer as an exe/library
 description:
   A rewrite of the shell script ghcup, for providing
@@ -341,6 +341,7 @@ executable ghcup
   import:
     config
     , base
+    , aeson
     , bytestring
     , containers
     , haskus-utils-variant

lib/GHCup.hs

@@ -77,7 +77,7 @@ import qualified Data.Text.Encoding            as E
 
 
 
-installGHCBin :: ( MonadFail m
+installGHCBindist :: ( MonadFail m
                  , MonadMask m
                  , MonadCatch m
                  , MonadReader Settings m
@@ -85,7 +85,7 @@ installGHCBin :: ( MonadFail m
                  , MonadResource m
                  , MonadIO m
                  )
-              => GHCupDownloads
+              => DownloadInfo
               -> Version
               -> PlatformRequest
               -> Excepts
@@ -102,14 +102,13 @@ installGHCBin :: ( MonadFail m
                     ]
                    m
                    ()
-installGHCBin bDls ver pfreq@(PlatformRequest {..}) = do
+installGHCBindist dlinfo ver (PlatformRequest {..}) = do
   let tver = (mkTVer ver)
   lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
   whenM (liftIO $ ghcInstalled tver)
     $ (throwE $ AlreadyInstalled GHC ver)
 
   -- download (or use cached version)
-  dlinfo                       <- lE $ getDownloadInfo GHC ver pfreq bDls
   dl                           <- liftE $ downloadCached dlinfo Nothing
 
   -- unpack
@@ -150,32 +149,62 @@ installGHCBin bDls ver pfreq@(PlatformRequest {..}) = do
     | otherwise = []
 
 
-installCabalBin :: ( MonadMask m
-                   , MonadCatch m
-                   , MonadReader Settings m
-                   , MonadLogger m
-                   , MonadResource m
-                   , MonadIO m
-                   , MonadFail m
-                   )
-                => GHCupDownloads
-                -> Version
-                -> PlatformRequest
-                -> Excepts
-                     '[ AlreadyInstalled
-                      , CopyError
-                      , DigestError
-                      , DownloadFailed
-                      , NoDownload
-                      , NotInstalled
-                      , UnknownArchive
+installGHCBin :: ( MonadFail m
+                 , MonadMask m
+                 , MonadCatch m
+                 , MonadReader Settings m
+                 , MonadLogger m
+                 , MonadResource m
+                 , MonadIO m
+                 )
+              => GHCupDownloads
+              -> Version
+              -> PlatformRequest
+              -> Excepts
+                   '[ AlreadyInstalled
+                    , BuildFailed
+                    , DigestError
+                    , DownloadFailed
+                    , NoDownload
+                    , NotInstalled
+                    , UnknownArchive
 #if !defined(TAR)
-                      , ArchiveResult
+                    , ArchiveResult
 #endif
-                      ]
-                     m
-                     ()
-installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do
+                    ]
+                   m
+                   ()
+installGHCBin bDls ver pfreq = do
+  dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
+  installGHCBindist dlinfo ver pfreq
+
+
+installCabalBindist :: ( MonadMask m
+                       , MonadCatch m
+                       , MonadReader Settings m
+                       , MonadLogger m
+                       , MonadResource m
+                       , MonadIO m
+                       , MonadFail m
+                       )
+                    => DownloadInfo
+                    -> Version
+                    -> PlatformRequest
+                    -> Excepts
+                         '[ AlreadyInstalled
+                          , CopyError
+                          , DigestError
+                          , DownloadFailed
+                          , NoDownload
+                          , NotInstalled
+                          , UnknownArchive
+#if !defined(TAR)
+                          , ArchiveResult
+#endif
+                          ]
+                         m
+                         ()
+installCabalBindist dlinfo ver (PlatformRequest {..}) = do
   lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
 
   bindir <- liftIO ghcupBinDir
@@ -190,7 +219,6 @@ installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do
     $ (throwE $ AlreadyInstalled Cabal ver)
 
   -- download (or use cached version)
-  dlinfo                       <- lE $ getDownloadInfo Cabal ver pfreq bDls
   dl                           <- liftE $ downloadCached dlinfo Nothing
 
   -- unpack
@@ -227,6 +255,37 @@ installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do
       Overwrite
 
 
+installCabalBin :: ( MonadMask m
+                   , MonadCatch m
+                   , MonadReader Settings m
+                   , MonadLogger m
+                   , MonadResource m
+                   , MonadIO m
+                   , MonadFail m
+                   )
+                => GHCupDownloads
+                -> Version
+                -> PlatformRequest
+                -> Excepts
+                     '[ AlreadyInstalled
+                      , CopyError
+                      , DigestError
+                      , DownloadFailed
+                      , NoDownload
+                      , NotInstalled
+                      , UnknownArchive
+#if !defined(TAR)
+                      , ArchiveResult
+#endif
+                      ]
+                     m
+                     ()
+installCabalBin bDls ver pfreq = do
+  dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
+  installCabalBindist dlinfo ver pfreq
+
+
+
 
     ---------------------
     --[ Set GHC/cabal ]--

lib/GHCup/Data/GHCupDownloads.hs

@@ -866,9 +866,9 @@ ghc_8101_32_alpine = DownloadInfo
 
 ghc_8101_64_freebsd :: DownloadInfo
 ghc_8101_64_freebsd = DownloadInfo
-  [uri|https://downloads.haskell.org/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz|]
+  [uri|https://files.hasufell.de/ghc/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz|]
   (Just [rel|ghc-8.10.1|])
-  "52d27dbf9de82005dde9bfc521bff612e381b5228af194259c2306d2b75825c2"
+  "e8646ec9b60fd40aa9505ee055f22f04601290ab7a1342c2cf37c34de9d3f142"
 
 
 

lib/GHCup/Utils/File.hs

@@ -10,6 +10,7 @@ import           GHCup.Utils.Prelude
 import           GHCup.Types
 
 import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 import           Control.Monad
@@ -57,14 +58,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
 
 
 
-
--- | Bool signals whether the regions should be cleaned.
-data StopThread = StopThread Bool
-  deriving Show
-
-instance Exception StopThread
-
-
 data ProcessError = NonZeroExit Int ByteString [ByteString]
                   | PTerminated ByteString [ByteString]
                   | PStopped ByteString [ByteString]
@@ -131,10 +124,9 @@ execLogged exe spath args lfile chdir env = do
       pState <- newEmptyMVar
       done   <- newEmptyMVar
       void
-        $ forkOS
-        $ EX.handle (\(_ :: StopThread) -> pure ())
+        $ forkIO
         $ EX.handle (\(_ :: IOException) -> pure ())
-        $ flip finally (putMVar done ())
+        $ flip EX.finally (putMVar done ())
         $ (if verbose
             then tee fd stdoutRead
             else printToRegion fd stdoutRead 6 pState
@@ -157,7 +149,7 @@ execLogged exe spath args lfile chdir env = do
       e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
       putMVar pState (either (const False) (const True) e)
 
-      takeMVar done
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
       closeFd stdoutRead
 
       pure e
@@ -225,33 +217,41 @@ execLogged exe spath args lfile chdir env = do
       | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
       | otherwise                 -> bs
 
-  -- read an entire line from the file descriptor (removes the newline char)
-  readLine :: MonadIO m => Fd -> ByteString -> m (ByteString, ByteString)
-  readLine fd = go
+  -- 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
-      bs <-
-        liftIO
-        $ handleIO (\e -> if isEOFError e then pure "" else ioError e)
-        $ SPIB.fdRead fd 512
-      let nbs          = BS.append inBs bs
-          (line, rest) = BS.span (/= _lf) nbs
-      if
-        | BS.length rest /= 0 -> pure (line, BS.tail rest)
-        | BS.length line == 0 -> pure (mempty, mempty)
-        | otherwise           -> (\(l, r) -> (line <> l, r)) <$!> go mempty
+      -- 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) <- readLine fd' bs'
-      if
-        | BS.length bs == 0 -> liftIO
-        $ ioError (mkIOError eofErrorType "" Nothing Nothing)
-        | otherwise -> do
-          void $ action' bs
-          go rest
+      (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
@@ -288,13 +288,12 @@ captureOutStreams action = do
       done   <- newEmptyMVar
       _      <-
         forkIO
-        $ EX.handle (\(_ :: StopThread) -> pure ())
         $ EX.handle (\(_ :: IOException) -> pure ())
-        $ flip finally (putMVar done ())
+        $ flip EX.finally (putMVar done ())
         $ writeStds parentStdoutRead parentStderrRead refOut refErr
 
       status <- SPPB.getProcessStatus True True pid
-      takeMVar done
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
 
       case status of
         -- readFd will take care of closing the fd
@@ -314,13 +313,13 @@ captureOutStreams action = do
     void
       $ forkIO
       $ hideError eofErrorType
-      $ flip finally (putMVar doneOut ())
+      $ flip EX.finally (putMVar doneOut ())
       $ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
     doneErr <- newEmptyMVar
     void
       $ forkIO
       $ hideError eofErrorType
-      $ flip finally (putMVar doneErr ())
+      $ flip EX.finally (putMVar doneErr ())
       $ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
     takeMVar doneOut
     takeMVar doneErr

lib/GHCup/Version.hs

@@ -16,7 +16,7 @@ ghcupURL :: URI
 ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
 
 ghcUpVer :: PVP
-ghcUpVer = [pver|0.1.7|]
+ghcUpVer = [pver|0.1.8|]
 
 numericVer :: String
 numericVer = T.unpack . prettyPVP $ ghcUpVer