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

Remove string-interpolate wrt #212

Browse Source
This commit is contained in:
Julian Ospald
2021-08-25 18:54:58 +02:00
parent a2555cecc5
commit 14fc6b7281
13 changed files with 277 additions and 247 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
lib/GHCup/Download.hs
View File

@@ -59,7 +59,6 @@ import Data.CaseInsensitive ( mk )
#endif
import Data.List.Extra
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Versions
@@ -187,13 +186,13 @@ 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) [i|Decoding yaml at: #{actualYaml}|]
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] JSONDecodeError
. fmap (first (\e -> [i|#{displayException e}
Consider removing "#{actualYaml}" manually.|]))
. fmap (first (\e -> unlines [displayException e
,"Consider removing " <> actualYaml <> " manually."]))
. liftIO
. Y.decodeFileEither
$ actualYaml
@@ -203,12 +202,12 @@ Consider removing "#{actualYaml}" manually.|]))
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> $(logWarn) [i|Couldn't remove file #{efp}, error was: #{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) [i|Could not get download info, trying cached version (this may not be recent!)|]
lift $ $(logDebug) [i|Error was: #{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
@@ -327,7 +326,7 @@ download uri eDigest dest mfn etags
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) [i|using local file: #{destFile'}|]
lift $ $(logDebug) $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@@ -336,7 +335,7 @@ download uri eDigest dest mfn etags
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) [i|downloading: #{uri'} as file #{destFile}|]
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
@@ -362,7 +361,7 @@ download uri eDigest dest mfn etags
metag <- readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", [i|If-None-Match: #{t}|]]) metag
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
headers <- liftIO $ T.readFile dh
@@ -371,9 +370,9 @@ 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 [i|Status code was 304, not overwriting|]
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
$logDebug [i|Status code was #{sc}, overwriting|]
$logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
@@ -389,7 +388,7 @@ download uri eDigest dest mfn etags
if etags
then do
metag <- readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", [i|If-None-Match: #{t}|]]) metag
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
@@ -453,7 +452,7 @@ download uri eDigest dest mfn etags
$logDebug "Couldn't parse etags, no input: "
pure Nothing
(Just [_, etag']) -> do
$logDebug [i|Parsed etag: #{etag'}|]
$logDebug $ "Parsed etag: " <> etag'
pure (Just etag')
(Just xs) -> do
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
@@ -466,10 +465,10 @@ download uri eDigest dest mfn etags
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
$logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
$logDebug [i|No etags files written|]
$logDebug "No etags files written"
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag fp = do
@@ -479,13 +478,13 @@ download uri eDigest dest mfn etags
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of
(Right et) -> do
$logDebug [i|Read etag: #{et}|]
$logDebug $ "Read etag: " <> et
pure (Just et)
(Left _) -> do
$logDebug [i|Etag file doesn't exist (yet)|]
$logDebug "Etag file doesn't exist (yet)"
pure Nothing
else do
$logDebug [i|Skipping and deleting etags file because destination file #{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
@@ -563,7 +562,7 @@ checkDigest eDigest file = do
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ $(logInfo) [i|verifying digest of: #{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)

78
lib/GHCup/Errors.hs
View File

@@ -4,7 +4,6 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -25,7 +24,6 @@ import Codec.Archive
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( CI )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
@@ -34,6 +32,7 @@ import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
@@ -88,7 +87,7 @@ data UnknownArchive = UnknownArchive FilePath
instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
text $ "The archive format is unknown. We don't know how to extract the file " <> file
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
@@ -111,7 +110,7 @@ data TagNotFound = TagNotFound Tag Tool
instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|]
text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
-- | Unable to find the next version of a tool (the one after the currently
-- set one).
@@ -120,7 +119,7 @@ data NextVerNotFound = NextVerNotFound Tool
instance Pretty NextVerNotFound where
pPrint (NextVerNotFound tool) =
text [i|Unable to find next (the one after the currently set one) version of tool "#{tool}"|]
text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
@@ -128,14 +127,14 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') =
text [i|#{tool}-#{prettyShow ver'} is already installed|]
pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
-- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath}
instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do
text [i|The directory was expected to be empty, but isn't: #{path}|]
text $ "The directory was expected to be empty, but isn't: " <> path
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
@@ -144,7 +143,7 @@ data NotInstalled = NotInstalled Tool GHCTargetVersion
instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath
@@ -152,7 +151,7 @@ data NotFoundInPATH = NotFoundInPATH FilePath
instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text [i|The exe "#{exe}" was not found in PATH.|]
text $ "The exe " <> exe <> " was not found in PATH."
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
@@ -160,7 +159,7 @@ data JSONError = JSONDecodeError String
instance Pretty JSONError where
pPrint (JSONDecodeError err) =
text [i|JSON decoding failed with: #{err}|]
text $ "JSON decoding failed with: " <> err
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
@@ -169,7 +168,7 @@ data FileDoesNotExistError = FileDoesNotExistError FilePath
instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text [i|File "#{file}" does not exist.|]
text $ "File " <> file <> " does not exist."
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
@@ -179,7 +178,7 @@ data FileAlreadyExistsError = FileAlreadyExistsError FilePath
instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
text [i|File "#{file}" Already exists.|]
text $ "File " <> file <> " Already exists."
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@@ -194,7 +193,7 @@ data DigestError = DigestError Text Text
instance Pretty DigestError where
pPrint (DigestError currentDigest expectedDigest) =
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
text "Digest error: expected" <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
@@ -202,7 +201,7 @@ data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status _) =
text [i|Unexpected HTTP status: #{status}|]
text "Unexpected HTTP status:" <+> pPrint status
-- | Malformed headers.
data MalformedHeaders = MalformedHeaders Text
@@ -210,7 +209,7 @@ data MalformedHeaders = MalformedHeaders Text
instance Pretty MalformedHeaders where
pPrint (MalformedHeaders h) =
text [i|Headers are malformed: #{h}|]
text "Headers are malformed: " <+> pPrint h
-- | Unexpected HTTP status.
data HTTPNotModified = HTTPNotModified Text
@@ -218,7 +217,7 @@ data HTTPNotModified = HTTPNotModified Text
instance Pretty HTTPNotModified where
pPrint (HTTPNotModified etag) =
text [i|Remote resource not modifed, etag was: #{etag}|]
text "Remote resource not modifed, etag was:" <+> pPrint etag
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
@@ -226,7 +225,7 @@ data NoLocationHeader = NoLocationHeader
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text [i|The 'Location' header was expected during a 3xx redirect, but not found.|]
text "The 'Location' header was expected during a 3xx redirect, but not found."
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
@@ -234,7 +233,7 @@ data TooManyRedirs = TooManyRedirs
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text [i|Too many redirections.|]
text "Too many redirections."
-- | A patch could not be applied.
data PatchFailed = PatchFailed
@@ -242,7 +241,7 @@ data PatchFailed = PatchFailed
instance Pretty PatchFailed where
pPrint PatchFailed =
text [i|A patch could not be applied.|]
text "A patch could not be applied."
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
@@ -250,35 +249,35 @@ data NoToolRequirements = NoToolRequirements
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text [i|The Tool requirements could not be found.|]
text "The Tool requirements could not be found."
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text [i|The build config is invalid. Reason was: #{reason}|]
text "The build config is invalid. Reason was:" <+> pPrint reason
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text [i|No version is set for tool "#{tool}".|]
text "No version is set for tool" <+> pPrint tool <+> text "."
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text [i|A download was required or requested, but '--offline' was specified.|]
text "A download was required or requested, but '--offline' was specified."
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
-------------------------
@@ -300,17 +299,17 @@ data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FileP
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason
text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
data GHCupSetError = forall es . (Show (V es), Pretty (V es)) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
text [i|Setting the current GHC version failed: #{reason}|]
text "Setting the current GHC version failed:" <+> pPrint reason
deriving instance Show GHCupSetError
@@ -326,7 +325,7 @@ data ParseError = ParseError String
instance Pretty ParseError where
pPrint (ParseError reason) =
text [i|Parsing failed: #{reason}|]
text "Parsing failed:" <+> pPrint reason
instance Exception ParseError
@@ -336,7 +335,7 @@ data UnexpectedListLength = UnexpectedListLength String
instance Pretty UnexpectedListLength where
pPrint (UnexpectedListLength reason) =
text [i|List length unexpected: #{reason}|]
text "List length unexpected:" <+> pPrint reason
instance Exception UnexpectedListLength
@@ -345,7 +344,7 @@ data NoUrlBase = NoUrlBase Text
instance Pretty NoUrlBase where
pPrint (NoUrlBase url) =
text [i|Couldn't get a base filename from url #{url}|]
text "Couldn't get a base filename from url" <+> pPrint url
instance Exception NoUrlBase
@@ -370,21 +369,21 @@ instance
instance Pretty URIParseError where
pPrint (MalformedScheme reason) =
text [i|Failed to parse URI. Malformed scheme: #{reason}|]
text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
pPrint MalformedUserInfo =
text [i|Failed to parse URI. Malformed user info.|]
text "Failed to parse URI. Malformed user info."
pPrint MalformedQuery =
text [i|Failed to parse URI. Malformed query.|]
text "Failed to parse URI. Malformed query."
pPrint MalformedFragment =
text [i|Failed to parse URI. Malformed fragment.|]
text "Failed to parse URI. Malformed fragment."
pPrint MalformedHost =
text [i|Failed to parse URI. Malformed host.|]
text "Failed to parse URI. Malformed host."
pPrint MalformedPort =
text [i|Failed to parse URI. Malformed port.|]
text "Failed to parse URI. Malformed port."
pPrint MalformedPath =
text [i|Failed to parse URI. Malformed path.|]
text "Failed to parse URI. Malformed path."
pPrint (OtherError err) =
text [i|Failed to parse URI: #{err}|]
text "Failed to parse URI:" <+> pPrint err
instance Pretty ArchiveResult where
pPrint ArchiveFatal = text "Archive result: fatal"
@@ -393,3 +392,6 @@ instance Pretty ArchiveResult where
pPrint ArchiveRetry = text "Archive result: retry"
pPrint ArchiveOk = text "Archive result: Ok"
pPrint ArchiveEOF = text "Archive result: EOF"
instance Pretty T.Text where
pPrint = text . T.unpack

3
lib/GHCup/Platform.hs
View File

@@ -33,7 +33,6 @@ import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
@@ -108,7 +107,7 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{prettyShow pfr}|]
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr)
pure pfr
where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing

7
lib/GHCup/Types.hs
View File

@@ -115,6 +115,13 @@ data Tool = GHC
| Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance Pretty Tool where
pPrint GHC = text "ghc"
pPrint Cabal = text "cabal"
pPrint GHCup = text "ghcup"
pPrint HLS = text "hls"
pPrint Stack = text "stack"
instance NFData Tool
data GlobalTool = ShimGen

41
lib/GHCup/Utils.hs
View File

@@ -62,7 +62,6 @@ import Data.List
import Data.List.Extra
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import GHC.IO.Exception
@@ -130,7 +129,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{fullF}|]
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -152,11 +151,11 @@ rmPlain target = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|]
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file)
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
@@ -180,7 +179,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|]
lift $ $(logDebug) "rm -f #{fullF}"
lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -296,7 +295,11 @@ cabalSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
$(logWarn) $ "Failed to parse cabal symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack cabalbin
<> " needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
pure Nothing
where
-- We try to be extra permissive with link destination parsing,
@@ -380,7 +383,11 @@ stackSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse stack symlink target with: "#{err}". The symlink #{stackBin} needs to point to valid stack binary, such as 'stack-2.7.1'.|]
$(logWarn) $ "Failed to parse stack symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack stackBin
<> " needs to point to valid stack binary, such as 'stack-2.7.1'."
pure Nothing
where
linkVersion :: MonadThrow m => FilePath -> m Version
@@ -602,7 +609,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
] m ()
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) [i|Unpacking: #{fn} to #{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
@@ -793,7 +800,7 @@ applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
lift $ $(logInfo) $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just)
(exec
"patch"
@@ -864,8 +871,8 @@ runBuildAction bdir instdir action = do
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn)
[i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
liftIO $ handleIO (\e -> run $ $(logWarn) $
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
@@ -999,17 +1006,17 @@ createLink link exe = do
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
$(logDebug) [i|rm -f #{exe}|]
$(logDebug) $ "rm -f " <> T.pack exe
rmLink exe
$(logDebug) [i|ln -s #{fullLink} #{exe}|]
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
$(logDebug) $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
$(logDebug) $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
#endif
@@ -1034,8 +1041,8 @@ ensureGlobalTools = do
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|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)

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

@@ -50,7 +50,6 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
@@ -274,7 +273,13 @@ 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) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(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)
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -282,7 +287,7 @@ mkGhcupTmpDir = do
liftIO $ createTempDirectory tmpdir "ghcup"
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
@@ -304,7 +309,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly
$ fp))
@@ -347,8 +352,8 @@ cleanupTrash = do
if null contents
then pure ()
else do
$(logWarn) [i|Removing leftover files in #{recycleDir}|]
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp))

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

@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -11,7 +10,6 @@ import GHCup.Utils.Prelude
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory
@@ -31,13 +29,13 @@ data ProcessError = NonZeroExit Int FilePath [String]
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " failed with exit code " <+> text (show e) <+> "."
pPrint (PTerminated exe args) =
text [i|Process "#{exe}" with arguments #{args} terminated.|]
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " terminated."
pPrint (PStopped exe args) =
text [i|Process "#{exe}" with arguments #{args} stopped.|]
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " stopped."
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode

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

@@ -35,7 +35,6 @@ import Data.ByteString ( ByteString )
import Data.Foldable
import Data.IORef
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.List
import Data.Word8
import GHC.IO.Exception
@@ -362,7 +361,7 @@ chmod_755 fp = do
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
$(logDebug) ("chmod 755 " <> T.pack fp)
liftIO $ setFileMode fp exe_mode