hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Drop monad-logger

Browse Source
This commit is contained in:
Julian Ospald
2021-08-30 22:41:58 +02:00
parent 3a7895e5ea
commit 13143b8e4d
19 changed files with 541 additions and 590 deletions
Download Patch File Download Diff File Expand all files Collapse all files

80
lib/GHCup/Download.hs
View File

@@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -34,8 +31,8 @@ import GHCup.Download.Utils
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -47,7 +44,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -112,7 +108,7 @@ getDownloadsF :: ( FromJSONKey Tool
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -165,7 +161,7 @@ getBase :: ( MonadReader env m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadMask m
)
=> URI
@@ -187,7 +183,7 @@ getBase uri = do
-- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
@@ -200,15 +196,15 @@ getBase uri = do
where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> $(logWarn) $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
warnCache s = do
lift $ $(logWarn) "Could not get download info, trying cached version (this may not be recent!)"
lift $ $(logDebug) $ "Error was: " <> T.pack s
lift $ logWarn "Could not get download info, trying cached version (this may not be recent!)"
lift $ logDebug $ "Error was: " <> T.pack s
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
@@ -222,7 +218,7 @@ getBase uri = do
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, HasLog env1
, MonadMask m1
)
=> URI
@@ -313,7 +309,7 @@ download :: ( MonadReader env m
, HasDirs env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> URI
@@ -327,7 +323,7 @@ download uri eDigest dest mfn etags
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) $ "using local file: " <> T.pack destFile'
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@@ -336,7 +332,7 @@ download uri eDigest dest mfn etags
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
@@ -359,7 +355,7 @@ download uri eDigest dest mfn etags
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
metag <- readETag destFile
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
@@ -371,14 +367,14 @@ download uri eDigest dest mfn etags
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
$logDebug $ "Status code was " <> sc <> ", overwriting"
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
writeEtags destFile (parseEtags headers)
lift $ writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -388,20 +384,20 @@ download uri eDigest dest mfn etags
o' <- liftIO getWgetOpts
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
$logDebug "Not modified, skipping download"
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -412,14 +408,14 @@ download uri eDigest dest mfn etags
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
@@ -445,33 +441,33 @@ download uri eDigest dest mfn etags
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
case T.words <$> mEtag of
(Just []) -> do
$logDebug "Couldn't parse etags, no input: "
logDebug "Couldn't parse etags, no input: "
pure Nothing
(Just [_, etag']) -> do
$logDebug $ "Parsed etag: " <> etag'
logDebug $ "Parsed etag: " <> etag'
pure (Just etag')
(Just xs) -> do
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
pure Nothing
Nothing -> do
$logDebug "No etags header found"
logDebug "No etags header found"
pure Nothing
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
$logDebug "No etags files written"
logDebug "No etags files written"
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag fp = do
e <- liftIO $ doesFileExist fp
if e
@@ -479,13 +475,13 @@ download uri eDigest dest mfn etags
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of
(Right et) -> do
$logDebug $ "Read etag: " <> et
logDebug $ "Read etag: " <> et
pure (Just et)
(Left _) -> do
$logDebug "Etag file doesn't exist (yet)"
logDebug "Etag file doesn't exist (yet)"
pure Nothing
else do
$logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing
@@ -498,7 +494,7 @@ downloadCached :: ( MonadReader env m
, MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -519,7 +515,7 @@ downloadCached' :: ( MonadReader env m
, HasSettings env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -553,7 +549,7 @@ checkDigest :: ( MonadReader env m
, HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
, HasLog env
)
=> T.Text -- ^ the hash
-> FilePath
@@ -563,7 +559,7 @@ checkDigest eDigest file = do
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ $(logInfo) $ "verifying digest of: " <> T.pack p'
lift $ logInfo $ "verifying digest of: " <> T.pack p'
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

8
lib/GHCup/Platform.hs
View File

@@ -20,6 +20,7 @@ module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -28,7 +29,6 @@ import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
@@ -57,7 +57,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -82,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -107,7 +107,7 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr)
lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
pure pfr
where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing

31
lib/GHCup/Types.hs
View File

@@ -25,21 +25,17 @@ module GHCup.Types
)
where
import Control.Applicative
import Control.DeepSeq ( NFData, rnf )
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -396,6 +392,7 @@ data AppState = AppState
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData AppState
@@ -404,6 +401,7 @@ data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData LeanAppState
@@ -555,14 +553,25 @@ instance Pretty Versioning where
instance Pretty Version where
pPrint = text . T.unpack . prettyVer
instance Show (a -> b) where
show _ = "<function>"
instance (Monad m, Alternative m) => Alternative (LoggingT m) where
empty = Trans.lift empty
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance Show (IO ()) where
show _ = "<io>"
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
data LogLevel = Warn
| Info
| Debug
| Error
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug

93
lib/GHCup/Types/Optics.hs
View File

@@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types.Optics
@@ -21,9 +22,13 @@ module GHCup.Types.Optics where
import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics
import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool
makePrisms ''Architecture
@@ -87,13 +92,15 @@ getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
)
=> m LeanAppState
getLeanAppState = do
s <- gets @"settings"
d <- gets @"dirs"
k <- gets @"keyBindings"
pure (LeanAppState s d k)
l <- gets @"loggerConfig"
pure (LeanAppState s d k l)
getSettings :: ( MonadReader env m
@@ -110,6 +117,87 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)
=> m (IO ())
getLogCleanup = gets @"logCleanup"
getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
@@ -136,6 +224,7 @@ type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)
getCache :: (MonadReader env m, HasSettings env) => m Bool

63
lib/GHCup/Utils.hs
View File

@@ -46,7 +46,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -113,7 +112,7 @@ ghcLinkDestination tool ver = do
rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -127,14 +126,14 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -149,11 +148,11 @@ rmPlain target = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file)
lift $ logDebug ("rm -f " <> T.pack hdc_file)
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
@@ -161,7 +160,7 @@ rmPlain target = do
rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -177,7 +176,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) "rm -f #{fullF}"
lift $ logDebug "rm -f #{fullF}"
lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -249,9 +248,9 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadLogger m
, MonadReader env m
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadCatch m
)
@@ -269,14 +268,14 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
@@ -293,7 +292,7 @@ cabalSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse cabal symlink target with: "
logWarn $ "Failed to parse cabal symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack cabalbin
@@ -364,7 +363,7 @@ getInstalledStacks = do
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet = do
Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt
@@ -381,7 +380,7 @@ stackSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse stack symlink target with: "
logWarn $ "Failed to parse stack symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack stackBin
@@ -599,7 +598,7 @@ getLatestGHCFor major' minor' dls =
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
@@ -607,7 +606,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
] m ()
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
@@ -630,7 +629,7 @@ unpackToDir dfp av = do
| otherwise -> throwE $ UnknownArchive fn
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
, ArchiveResult
@@ -659,7 +658,7 @@ getArchiveFiles av = do
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m FilePath
@@ -787,14 +786,14 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) $ "Applying patch " <> T.pack patch'
lift $ logInfo $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just)
(exec
"patch"
@@ -835,7 +834,7 @@ runBuildAction :: ( Pretty (V e)
, HasSettings env
, MonadIO m
, MonadMask m
, MonadLogger m
, HasLog env
, MonadUnliftIO m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
@@ -863,9 +862,9 @@ runBuildAction bdir instdir action = do
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn) $
liftIO $ handleIO (\e -> run $ logWarn $
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
@@ -978,7 +977,7 @@ rmLink = hideError doesNotExistErrorType . recycleFile
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1000,24 +999,24 @@ createLink link exe = do
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
rmLink exe
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) $ "ln -s " <> T.pack link <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1035,8 +1034,8 @@ ensureGlobalTools = do
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) "Digest doesn't match, redownloading gs.exe..."
lift $ $(logDebug) "rm -f #{shimDownload}"
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug "rm -f #{shimDownload}"
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)

21
lib/GHCup/Utils/Dirs.hs
View File

@@ -2,9 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Dirs
@@ -45,7 +43,6 @@ import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
@@ -261,7 +258,7 @@ parseGHCupGHCDir (T.pack -> fp) =
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadThrow m
, MonadMask m
@@ -273,14 +270,14 @@ mkGhcupTmpDir = do
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) ("Possibly insufficient disk space on "
logWarn ("Possibly insufficient disk space on "
<> T.pack tmpdir
<> ". At least "
<> T.pack (show minSpace)
<> " MB are recommended, but only "
<> toMB (fromJust space)
<> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
$(logWarn)
logWarn
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -295,8 +292,9 @@ mkGhcupTmpDir = do
withGHCupTmpDir :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadLogger m
, MonadCatch m
, MonadResource m
, MonadThrow m
@@ -309,7 +307,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
$ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly
$ fp))
@@ -341,9 +339,10 @@ relativeSymlink p1 p2 =
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
)
=> m ()
cleanupTrash = do
@@ -352,8 +351,8 @@ cleanupTrash = do
if null contents
then pure ()
else do
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir)
logWarn ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp))

8
lib/GHCup/Utils/File/Posix.hs
View File

@@ -1,8 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
@@ -28,7 +25,6 @@ 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 )
@@ -350,7 +346,7 @@ toProcessError exe args mps = case mps of
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
@@ -361,7 +357,7 @@ chmod_755 fp = do
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) ("chmod 755 " <> T.pack fp)
logDebug ("chmod 755 " <> T.pack fp)
liftIO $ setFileMode fp exe_mode

50
lib/GHCup/Utils/Logger.hs
View File

@@ -22,11 +22,8 @@ import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Char ( ord )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
@@ -35,53 +32,6 @@ import qualified Data.ByteString as B
import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> toLogStr (style' "[ ... ] ") <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug:"
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: ( MonadReader env m
, HasDirs env

10
lib/GHCup/Utils/Prelude.hs
View File

@@ -5,7 +5,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Prelude
@@ -30,7 +29,6 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf )
@@ -176,8 +174,12 @@ lEM' :: forall e' e es a m
lEM' f em = lift em >>= lE . first f
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v))
catchWarn :: forall es m env . ( Pretty (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight