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

Windows support

Browse Source
This commit is contained in:
Julian Ospald
2021-05-14 23:09:45 +02:00
parent 9793fc6888
commit 2f62067d96
49 changed files with 16670 additions and 17812 deletions
Download Patch File Download Diff File Expand all files Collapse all files

677
lib/GHCup.hs
View File

File diff suppressed because it is too large Load Diff

255
lib/GHCup/Download.hs
View File

@@ -16,7 +16,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
Module for handling all download related functions.
@@ -36,7 +36,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
@@ -57,7 +57,7 @@ import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
#endif
import Data.List ( find )
import Data.List.Extra
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
@@ -68,32 +68,29 @@ import Data.Time.Format
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Error
import System.Posix.Env.ByteString ( getEnv )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
@@ -115,26 +112,26 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> URLSource
=> Settings
-> Dirs
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF urlSource = do
getDownloadsF settings@Settings{ urlSource } dirs = do
case urlSource of
GHCupURL -> liftE getBase
GHCupURL -> liftE $ getBase dirs settings
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE getBase
base <- liftE $ getBase dirs settings
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
base <- liftE $ getBase dirs settings
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
@@ -143,36 +140,39 @@ getDownloadsF urlSource = do
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
-> GHCupInfo
mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
let new = M.mapWithKey (\k a -> case M.lookup k ext of
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
Just a' -> M.union a' a
Nothing -> a
) base
in GHCupInfo tr new
) base
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache Dirs {..} = do
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
yaml_file <- (cacheDir </>) <$> urlBaseName path
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
(\_ -> throwE $ FileDoesNotExistError yaml_file)
$ liftIO
$ readFile yaml_file
$ L.readFile yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
=> Dirs
-> Settings
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } =
handleIO (\_ -> readFromCache dirs)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
(\(DownloadFailed _) -> readFromCache dirs)
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where
@@ -190,7 +190,6 @@ getBase =
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, MonadReader AppState m1
)
=> URI
-> Excepts
@@ -205,31 +204,28 @@ getBase =
m1
L.ByteString
smartDl uri' = do
AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
json_file <- (cacheDir </>) <$> urlBaseName path
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file
if e
then do
accessTime <-
PF.accessTimeHiRes
<$> liftIO (PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO getPOSIXTime
accessTime <- liftIO $ getAccessTime json_file
currentTime <- liftIO getCurrentTime
-- access time won't work on most linuxes, but we can try regardless
if (currentTime - accessTime) > 300
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
then do -- no access in last 5 minutes, re-check upstream mod time
getModTime >>= \case
Just modTime -> do
fileMod <- liftIO $ getModificationTime json_file
if modTime > fileMod
then dlWithMod modTime json_file
else liftIO $ readFile json_file
else liftIO $ L.readFile json_file
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
dlWithoutMod json_file
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
liftIO $ L.readFile json_file
else do
liftIO $ createDirRecursive' cacheDir
getModTime >>= \case
@@ -242,14 +238,14 @@ getBase =
where
dlWithMod modTime json_file = do
bs <- liftE $ downloadBS uri'
bs <- liftE $ downloadBS downloader uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
liftIO $ writeFileL json_file (Just newFilePerms) bs
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
bs <- liftE $ downloadBS downloader uri'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -278,11 +274,10 @@ getBase =
#endif
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
writeFileWithModTime utctime path content = do
let mod_time = utcTimeToPOSIXSeconds utctime
writeFileL path (Just newFilePerms) content
setModificationTimeHiRes path mod_time
L.writeFile path content
setModificationTime path utctime
getDownloadInfo :: Tool
@@ -328,16 +323,16 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
--
-- The file must not exist.
download :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn
=> Settings
-> DownloadInfo
-> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
download settings@Settings{ downloader } dli dest mfn
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = cp
@@ -348,9 +343,9 @@ download dli dest mfn
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
let destFile = getDestFile
let fromFile = T.unpack . decUTF8Safe $ path
liftIO $ copyFile fromFile destFile
pure destFile
dl = do
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
@@ -358,37 +353,37 @@ download dli dest mfn
-- destination dir must exist
liftIO $ createDirRecursive' dest
destFile <- getDestFile
let destFile = getDestFile
-- download
flip onException
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
(liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
lift getDownloader >>= \case
case downloader of
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
Wget -> do
o' <- liftIO getWgetOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ exec "wget"
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
liftE $ downloadToFile https host fullPath port destFile
#endif
liftE $ checkDigest dli destFile
liftE $ checkDigest settings dli destFile
pure destFile
-- Manage to find a file we can write the body into.
getDestFile :: MonadThrow m => m (Path Abs)
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
getDestFile :: FilePath
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
path = view (dlUri % pathL') dli
@@ -401,27 +396,40 @@ downloadCached :: ( MonadMask m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadReader AppState m
)
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do
cache <- lift getCache
=> Settings
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached settings@Settings{ cache } dirs dli mfn = do
case cache of
True -> do
AppState {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure cachfile
| otherwise -> liftE $ download dli cacheDir mfn
True -> downloadCached' settings dirs dli mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn
liftE $ download settings dli tmp mfn
downloadCached' :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
)
=> Settings
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' settings Dirs{..} dli mfn = do
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest settings dli cachfile
pure cachfile
| otherwise -> liftE $ download settings dli cacheDir mfn
@@ -434,8 +442,9 @@ downloadCached dli mfn = do
-- | This is used for downloading the JSON.
downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m)
=> URI
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
=> Downloader
-> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
@@ -447,14 +456,14 @@ downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m)
]
m
L.ByteString
downloadBS uri'
downloadBS downloader uri'
| scheme == "https"
= dl True
| scheme == "http"
= dl False
| scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
(liftIO $ RD.readFile path)
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
| otherwise
= throwE UnsupportedScheme
@@ -467,23 +476,23 @@ downloadBS uri'
dl _ = do
#endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
lift getDownloader >>= \case
case downloader of
Curl -> do
o' <- liftIO getCurlOpts
let exe = [rel|curl|]
args = o' ++ ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
let exe = "curl"
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
Wget -> do
o' <- liftIO getWgetOpts
let exe = [rel|wget|]
args = o' ++ ["-qO-", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
let exe = "wget"
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
lift (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
@@ -491,33 +500,39 @@ downloadBS uri'
#endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo
-> Path Abs
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Settings
-> DownloadInfo
-> FilePath
-> Excepts '[DigestError] m ()
checkDigest dli file = do
verify <- lift ask <&> (not . noVerify . settings)
checkDigest Settings{ noVerify } dli file = do
let verify = not noVerify
when verify $ do
p' <- toFilePath <$> basename file
let p' = takeFileName file
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
c <- liftIO $ readFile file
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
let eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [ByteString]
getCurlOpts :: IO [String]
getCurlOpts =
getEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ BS.split _space r
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [ByteString]
getWgetOpts :: IO [String]
getWgetOpts =
getEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ BS.split _space r
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False

15
lib/GHCup/Download/IOStreams.hs
View File

@@ -24,8 +24,6 @@ import Data.CaseInsensitive ( CI )
import Data.IORef
import Data.Maybe
import Data.Text.Read
import HPath
import HPath.IO as HIO
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import Optics
@@ -33,11 +31,8 @@ import Prelude hiding ( abs
, readFile
, writeFile
)
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import System.ProgressBar
import System.IO
import URI.ByteString
import qualified Data.ByteString as BS
@@ -81,12 +76,12 @@ downloadToFile :: (MonadMask m, MonadIO m)
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination file to create and write to
-> FilePath -- ^ destination file to create and write to
-> Excepts '[DownloadFailed] m ()
downloadToFile https host fullPath port destFile = do
fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd
flip finally (liftIO $ closeFd fd)
fd <- liftIO $ openFile destFile WriteMode
let stepper = BS.hPut fd
flip finally (liftIO $ hClose fd)
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper

21
lib/GHCup/Errors.hs
View File

@@ -15,12 +15,11 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Errors where
import GHCup.Types
import GHCup.Utils.Prelude
#if !defined(TAR)
import Codec.Archive
@@ -28,11 +27,9 @@ import Codec.Archive
import qualified Codec.Archive.Tar as Tar
#endif
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import Haskus.Utils.Variant
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
@@ -86,12 +83,12 @@ instance Pretty DistroNotFound where
text "Unable to figure out the distribution of the host."
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive ByteString
data UnknownArchive = UnknownArchive FilePath
deriving Show
instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text [i|The archive format is unknown. We don't know how to extract the file "#{decUTF8Safe file}"|]
text [i|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
@@ -143,12 +140,12 @@ instance Pretty NotInstalled where
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH (Path Rel)
data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show
instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
text [i|The exe "#{exe}" was not found in PATH.|]
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
@@ -160,12 +157,12 @@ instance Pretty JSONError where
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError ByteString
data FileDoesNotExistError = FileDoesNotExistError FilePath
deriving Show
instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text [i|File "#{decUTF8Safe file}" does not exist.|]
text [i|File "#{file}" does not exist.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@@ -252,11 +249,11 @@ deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
text [i|BuildFailed failed in dir "#{path}": #{reason}|]
deriving instance Show BuildFailed

57
lib/GHCup/Platform.hs
View File

@@ -13,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Platform where
@@ -36,18 +36,20 @@ import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Info
import System.Directory
import System.OsRelease
import Text.Regex.Posix
import qualified Data.Text as T
import qualified Data.Text.IO as T
--------------------------
--[ Platform detection ]--
@@ -55,7 +57,7 @@ import qualified Data.Text as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -80,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -96,35 +98,35 @@ getPlatform = do
. versioning
-- TODO: maybe do this somewhere else
. getMajorVersion
. decUTF8Safe
. decUTF8Safe'
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
"freebsd" -> do
ver <-
either (const Nothing) Just . versioning . decUTF8Safe
either (const Nothing) Just . versioning . decUTF8Safe'
<$> getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
getFreeBSDVersion =
liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
["-productVersion"]
Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)
getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
[ liftIO try_os_release
, try_lsb_release_cmd
, try_redhat_release
, try_debian_version
, liftIO try_redhat_release
, liftIO try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
@@ -147,12 +149,12 @@ getLinuxDistro = do
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
lsb_release_cmd :: FilePath
lsb_release_cmd = "lsb-release"
redhat_release :: FilePath
redhat_release = "/etc/redhat-release"
debian_version :: FilePath
debian_version = "/etc/debian_version"
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
@@ -160,16 +162,17 @@ getLinuxDistro = do
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd :: (MonadFail m, MonadIO m)
=> m (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- findExecutable lsb_release_cmd
(Just _) <- liftIO $ findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap decUTF8Safe' $ readFile redhat_release
t <- T.readFile redhat_release
let nameRegex n =
makeRegexOpts compIgnoreCase
execBlank
@@ -191,5 +194,5 @@ getLinuxDistro = do
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
ver <- readFile debian_version
pure (T.pack "debian", Just . decUTF8Safe' $ ver)
ver <- T.readFile debian_version
pure (T.pack "debian", Just ver)

2
lib/GHCup/Requirements.hs
View File

@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Requirements where

130
lib/GHCup/Types.hs
View File

@@ -2,7 +2,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Types
@@ -11,26 +10,43 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Types where
module GHCup.Types
( module GHCup.Types
#if defined(BRICK)
, Key(..)
#endif
)
where
import Control.Applicative
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
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 Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
#if !defined(BRICK)
data Key = KEsc | KChar Char | KBS | KEnter
| KLeft | KRight | KUp | KDown
| KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
| KFun Int | KBackTab | KPrtScr | KPause | KIns
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
deriving (Eq,Show,Read,Ord,GHC.Generic)
#endif
--------------------
--[ GHCInfo Tree ]--
@@ -40,6 +56,7 @@ import qualified Graphics.Vty as Vty
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
}
deriving (Show, GHC.Generic)
@@ -88,6 +105,9 @@ data Tool = GHC
| Stack
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-- | All necessary information of a tool version, including
-- source download and per-architecture downloads.
@@ -157,12 +177,15 @@ data Platform = Linux LinuxDistro
| Darwin
-- ^ must exit
| FreeBSD
| Windows
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
platformToString :: Platform -> String
platformToString (Linux distro) = "linux-" ++ distroToString distro
platformToString Darwin = "darwin"
platformToString FreeBSD = "freebsd"
platformToString Windows = "windows"
instance Pretty Platform where
pPrint = text . platformToString
@@ -218,12 +241,12 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
data TarDir = RealDir FilePath
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Ord, GHC.Generic, Show)
instance Pretty TarDir where
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
pPrint (RealDir path) = text path
pPrint (RegexDir regex) = text regex
@@ -250,48 +273,50 @@ defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Vty.Key
, kDown :: Maybe Vty.Key
, kQuit :: Maybe Vty.Key
, kInstall :: Maybe Vty.Key
, kUninstall :: Maybe Vty.Key
, kSet :: Maybe Vty.Key
, kChangelog :: Maybe Vty.Key
, kShowAll :: Maybe Vty.Key
, kShowAllTools :: Maybe Vty.Key
{ kUp :: Maybe Key
, kDown :: Maybe Key
, kQuit :: Maybe Key
, kInstall :: Maybe Key
, kUninstall :: Maybe Key
, kSet :: Maybe Key
, kChangelog :: Maybe Key
, kShowAll :: Maybe Key
, kShowAllTools :: Maybe Key
}
deriving (Show, GHC.Generic)
data KeyBindings = KeyBindings
{ bUp :: Vty.Key
, bDown :: Vty.Key
, bQuit :: Vty.Key
, bInstall :: Vty.Key
, bUninstall :: Vty.Key
, bSet :: Vty.Key
, bChangelog :: Vty.Key
, bShowAllVersions :: Vty.Key
, bShowAllTools :: Vty.Key
{ bUp :: Key
, bDown :: Key
, bQuit :: Key
, bInstall :: Key
, bUninstall :: Key
, bSet :: Key
, bChangelog :: Key
, bShowAllVersions :: Key
, bShowAllTools :: Key
}
deriving (Show, GHC.Generic)
defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings
{ bUp = Vty.KUp
, bDown = Vty.KDown
, bQuit = Vty.KChar 'q'
, bInstall = Vty.KChar 'i'
, bUninstall = Vty.KChar 'u'
, bSet = Vty.KChar 's'
, bChangelog = Vty.KChar 'c'
, bShowAllVersions = Vty.KChar 'a'
, bShowAllTools = Vty.KChar 't'
{ bUp = KUp
, bDown = KDown
, bQuit = KChar 'q'
, bInstall = KChar 'i'
, bUninstall = KChar 'u'
, bSet = KChar 's'
, bChangelog = KChar 'c'
, bShowAllVersions = KChar 'a'
, bShowAllTools = KChar 't'
}
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
} deriving (Show)
data Settings = Settings
@@ -305,11 +330,11 @@ data Settings = Settings
deriving (Show, GHC.Generic)
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
, confDir :: Path Abs
{ baseDir :: FilePath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
}
deriving Show
@@ -326,10 +351,10 @@ data Downloader = Curl
deriving (Eq, Show, Ord)
data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs
, diBinDir :: Path Abs
, diGHCDir :: Path Abs
, diCacheDir :: Path Abs
{ diBaseDir :: FilePath
, diBinDir :: FilePath
, diGHCDir :: FilePath
, diCacheDir :: FilePath
, diArch :: Architecture
, diPlatform :: PlatformResult
}
@@ -422,3 +447,16 @@ instance Pretty Versioning where
instance Pretty Version where
pPrint = text . T.unpack . prettyVer
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 MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d

54
lib/GHCup/Types/JSON.hs
View File

@@ -17,7 +17,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Types.JSON where
@@ -33,38 +33,27 @@ import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Text.Encoding as E
import Data.Versions
import Data.Void
import Data.Word8
import HPath
import URI.ByteString
import Text.Casing
import qualified Data.ByteString as BS
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
instance ToJSON Tag where
toJSON Latest = String "Latest"
@@ -128,11 +117,13 @@ instance ToJSONKey Platform where
Darwin -> T.pack "Darwin"
FreeBSD -> T.pack "FreeBSD"
Linux d -> T.pack ("Linux_" <> show d)
Windows -> T.pack "Windows"
instance FromJSONKey Platform where
fromJSONKey = FromJSONKeyTextParser $ \t -> if
| T.pack "Darwin" == t -> pure Darwin
| T.pack "FreeBSD" == t -> pure FreeBSD
| T.pack "Windows" == t -> pure Windows
| T.pack "Linux_" `T.isPrefixOf` t -> case
T.stripPrefix (T.pack "Linux_") t
of
@@ -199,19 +190,11 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . decUTF8Safe $ fp
False -> String "/not/a/valid/path"
where fp = toFilePath p
instance FromJSON (Path Rel) where
parseJSON = withText "HPath Rel" $ \t -> do
let d = encodeUtf8 t
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
instance ToJSONKey GlobalTool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p
@@ -322,3 +305,14 @@ instance FromJSONKey (Maybe VersionRange) where
just t = case MP.parse versionRangeP "" t of
Right x -> pure $ Just x
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings

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

@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Types.Optics where

624
lib/GHCup/Utils.hs
View File

File diff suppressed because it is too large Load Diff

4
lib/GHCup/Utils.hs-boot Normal file
View File

@@ -0,0 +1,4 @@
module GHCup.Utils where
getLinkTarget :: FilePath -> IO FilePath
pathIsLink :: FilePath -> IO Bool

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

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -12,10 +13,11 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
, ghcupGHCBaseDir
@@ -34,7 +36,6 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
@@ -42,32 +43,24 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
#if !defined(IS_WINDOWS)
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Directory
#endif
import System.DiskSpace
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp )
#if !defined(IS_WINDOWS)
import System.Environment
#endif
import System.FilePath
import System.IO.Temp
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -82,96 +75,116 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir :: IO FilePath
ghcupBaseDir = do
#if defined(IS_WINDOWS)
pure ("C:\\" </> "ghcup")
#else
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_DATA_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/share|])
pure (bdir </> [rel|ghcup|])
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
pure (bdir </> ".ghcup")
#endif
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO (Path Abs)
ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
#if defined(IS_WINDOWS)
pure ("C:\\" </> "ghcup")
#else
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.config|])
pure (bdir </> [rel|ghcup|])
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
pure (bdir </> ".ghcup")
#endif
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO (Path Abs)
ghcupBinDir :: IO FilePath
ghcupBinDir = do
#if defined(IS_WINDOWS)
pure ("C:\\" </> "ghcup" </> "bin")
#else
xdg <- useXDG
if xdg
then do
getEnv "XDG_BIN_HOME" >>= \case
Just r -> parseAbs r
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/bin|])
else ghcupBaseDir <&> (</> [rel|bin|])
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir :: IO FilePath
ghcupCacheDir = do
#if defined(IS_WINDOWS)
pure ("C:\\" </> "ghcup" </> "cache")
#else
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup|])
else ghcupBaseDir <&> (</> [rel|cache|])
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir :: IO FilePath
ghcupLogsDir = do
#if defined(IS_WINDOWS)
pure ("C:\\" </> "ghcup" </> "logs")
#else
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup/logs|])
else ghcupBaseDir <&> (</> [rel|logs|])
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
getDirs :: IO Dirs
@@ -194,11 +207,11 @@ ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
confDir <- liftIO ghcupConfigDir
let file = confDir </> [rel|config.yaml|]
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of
let file = confDir </> "config.yaml"
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
case contents of
Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
-------------------------
@@ -207,10 +220,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
pure (baseDir </> [rel|ghc|])
pure (baseDir </> "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -219,35 +232,32 @@ ghcupGHCBaseDir = do
-- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion
-> m (Path Abs)
-> m FilePath
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir </> verdir)
-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
parseGHCupGHCDir (toFilePath -> f) = do
fp <- throwEither $ E.decodeUtf8' f
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
let fp = T.unpack $ decUTF8Safe tmpdir
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) [i|Possibly insufficient disk space on #{fp}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(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)
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
parseAbs tmp
liftIO $ createTempDirectory tmpdir "ghcup"
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
@@ -256,8 +266,8 @@ mkGhcupTmpDir = do
where t = 10^n
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
@@ -267,29 +277,21 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv "HOME"
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
#if !defined(IS_WINDOWS)
useXDG :: IO Bool
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
#endif
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
-> Path Abs -- ^ the symlink destination
-> ByteString
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination
-> FilePath
relativeSymlink p1 p2 =
let d1 = splitDirectories p1
d2 = splitDirectories p2
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : drop (length common) d2)
<> joinPath ([pathSeparator] : drop (length common) d2)

511
lib/GHCup/Utils/File.hs
View File

@@ -1,494 +1,17 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File where
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
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.Foldable
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
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import Optics hiding ((<|), (|>))
import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
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, oAppend )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process.ByteString
as SPPB
import Streamly.External.Posix.DirStream
import qualified Streamly.Prelude as S
import qualified Text.Megaparsec as MP
import qualified Data.ByteString as BS
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
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args}.|]
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
, _stdErr :: ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
-- This shouldn't throw IO exceptions, unless getting the environment variable
-- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap
(handleIO (\_ -> pure Nothing)
-- asum for short-circuiting behavior
. (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
)
sPaths
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO CapturedProcess
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: (MonadReader AppState 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 (opened in append mode)
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
closeFd
(action verbose)
where
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
(putMVar done ())
-- fork the subprocess
pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env
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 $ 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")
-- 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 (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
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 = go
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
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action = do
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- start thread that writes the output
refOut <- newIORef BS.empty
refErr <- newIORef BS.empty
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPPB.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
case status of
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds pout perr rout rerr = do
doneOut <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
takeMVar doneOut
takeMVar doneErr
readTilEOF ~action' fd' = do
bs <- SPIB.fdRead fd' 512
void $ action' bs
readTilEOF action' fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> Path b -> IO Fd
createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
-- | Thin wrapper around `executeFile`.
exec :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
exec exe spath args chdir env = do
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
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
Nothing -> Left $ NoSuchPid exe args
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
$ do
dirStream <- openDirStream (toFilePath x)
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
>>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == toFilePath needle
then isExecutable (basedir </> needle)
else pure False
-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: Path Abs -> IO (Maybe (Path Abs))
isShadowed p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
searchPath shadowPaths fn
else pure Nothing
-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: Path Abs -> IO Bool
isInPath p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
findFiles :: Path Abs -> Regex -> IO [Path Rel]
findFiles path regex = do
dirStream <- openDirStream (toFilePath path)
f <-
(fmap . fmap) snd
. S.toList
. S.filter (\(_, p) -> match regex p)
$ dirContentsStream dirStream
pure $ parseRel =<< f
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
findFiles' path parser = do
dirStream <- openDirStream (toFilePath path)
f <-
(fmap . fmap) snd
. S.toList
. S.filter (\(_, p) -> case E.decodeUtf8' p of
Left _ -> False
Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream
pure $ parseRel =<< f
isBrokenSymlink :: Path Abs -> IO Bool
isBrokenSymlink p =
handleIO
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
$ do
_ <- canonicalizePath p
pure False
chmod_755 :: (MonadLogger m, MonadIO m) => Path a -> m ()
chmod_755 (toFilePath -> fp) = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
liftIO $ setFileMode fp exe_mode
{-# LANGUAGE CPP #-}
module GHCup.Utils.File (
module GHCup.Utils.File.Common,
#if IS_WINDOWS
module GHCup.Utils.File.Windows
#else
module GHCup.Utils.File.Posix
#endif
) where
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif

106
lib/GHCup/Utils/File/Common.hs Normal file
View File

@@ -0,0 +1,106 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils.File.Common where
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
import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Data.ByteString.Lazy as BL
data ProcessError = NonZeroExit Int FilePath [String]
| PTerminated FilePath [String]
| PStopped FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{exe}" with arguments #{args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{exe}" with arguments #{args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString
, _stdErr :: BL.ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
$ do
contents <- listDirectory x
findM (isMatch x) contents >>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == needle
then isExecutable (basedir </> needle)
else pure False
isExecutable :: FilePath -> IO Bool
isExecutable file = executable <$> getPermissions file
-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: FilePath -> IO (Maybe FilePath)
isShadowed p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
searchPath shadowPaths fn
else pure Nothing
-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: FilePath -> IO Bool
isInPath p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
findFiles :: FilePath -> Regex -> IO [FilePath]
findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents

386
lib/GHCup/Utils/File/Posix.hs Normal file
View File

@@ -0,0 +1,386 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
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
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
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
import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
import System.IO.Error
import System.FilePath
import System.Directory
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process as SPP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
executeOut path args chdir = liftIO $ captureOutStreams $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile path True args Nothing
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd
(action verbose)
where
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
(putMVar done ())
-- fork the subprocess
pid <- SPP.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
-- execute the action
maybe (pure ()) changeWorkingDirectory chdir
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
putMVar pState (either (const False) (const True) 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")
-- 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 (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 -> "[ " <> E.encodeUtf8 (T.pack 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
-- 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 = go
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
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action = do
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPP.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- start thread that writes the output
refOut <- newIORef BL.empty
refErr <- newIORef BL.empty
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPP.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
case status of
-- readFd will take care of closing the fd
Just (SPP.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
writeStds pout perr rout rerr = do
doneOut <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
takeMVar doneOut
takeMVar doneErr
readTilEOF ~action' fd' = do
bs <- SPIB.fdRead fd' 512
void $ action' bs
readTilEOF action' fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> FilePath -> IO Fd
createRegularFileFd fm dest =
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> String -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
exec exe args chdir env = liftIO $ do
pid <- SPP.forkProcess $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
toProcessError :: FilePath
-> [String]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPP.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e

240
lib/GHCup/Utils/File/Windows.hs Normal file
View File

@@ -0,0 +1,240 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
Module : GHCup.Utils.File.Windows
Description : File and windows APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : Windows
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Windows where
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
import GHCup.Types
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import System.Process
import qualified Control.Exception as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
toProcessError :: FilePath
-> [FilePath]
-> ExitCode
-> Either ProcessError ()
toProcessError exe args exitcode = case exitcode of
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
ExitSuccess -> Right ()
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
-- lets you pass 'CreateProcess' giving better flexibility.
--
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
-- record will be ignored.
--
-- @since 1.2.3.0
readCreateProcessWithExitCodeBS
:: CreateProcess
-> BL.ByteString
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
readCreateProcessWithExitCodeBS cp input = do
let cp_opts = cp {
std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe
}
withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
\mb_inh mb_outh mb_errh ph ->
case (mb_inh, mb_outh, mb_errh) of
(Just inh, Just outh, Just errh) -> do
out <- BS.hGetContents outh
err <- BS.hGetContents errh
-- fork off threads to start consuming stdout & stderr
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
-- now write any input
unless (BL.null input) $
ignoreSigPipe $ BL.hPut inh input
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
ignoreSigPipe $ hClose inh
-- wait on the output
waitOut
waitErr
hClose outh
hClose errh
-- wait on the process
ex <- waitForProcess ph
return (ex, BL.fromStrict out, BL.fromStrict err)
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
where
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = EX.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
-- wrapper so we can get exceptions with the appropriate function name.
withCreateProcess_
:: String
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess_ fun c action =
EX.bracketOnError (createProcess_ fun c) cleanupProcess
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async' body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async') >>= putMVar waitVar
let wait' = takeMVar waitVar >>= either throwIO return
restore (body wait') `EX.onException` killThread tid
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
=> FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess
executeOut path args chdir = do
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
pure $ CapturedProcess exit out err
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log"
cp <- createProcessWithMingwPath ((proc exe args)
{ cwd = chdir
, env = env
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
})
fmap (toProcessError exe args)
$ liftIO
$ withCreateProcess cp
$ \_ mout merr ph ->
case (mout, merr) of
(Just cStdout, Just cStderr) -> do
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
waitOut
waitErr
waitForProcess ph
_ -> fail "Could not acquire out/err handle"
where
tee :: FilePath -> Handle -> IO ()
tee logFile handle' = go
where
go = do
some <- BS.hGetSome handle' 512
if BS.null some
then pure ()
else do
void $ BS.appendFile logFile some
void $ BS.hPut stdout some
go
-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
=> FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
exec exe args chdir env = do
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code
chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp =
let perm = setOwnerWritable True emptyPermissions
in liftIO $ setPermissions fp perm
createProcessWithMingwPath :: MonadIO m
=> CreateProcess
-> m CreateProcess
createProcessWithMingwPath cp = do
baseDir <- liftIO ghcupBaseDir
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
let mingWPaths = [baseDir </> "msys64" </> "usr" </> "bin"
,baseDir </> "msys64" </> "mingw64" </> "bin"]
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
envWithNewPath = Map.insert "Path" newPath envWithoutPath
liftIO $ setEnv "Path" newPath
pure $ cp { env = Just $ Map.toList envWithNewPath }
-- | Checks whether the binary is a broken link.
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
b <- pathIsLink fp
if b
then do
tfp <- getLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp)
else pure False

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

@@ -8,29 +8,27 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
Here we define our main logger.
-}
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.String.QQ
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.Directory hiding ( findFiles )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import qualified Data.ByteString as B
import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
@@ -68,19 +66,18 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
initGHCupFileLogging = do
AppState {dirs = Dirs {..}} <- ask
let logfile = logsDir </> [rel|ghcup.log|]
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
initGHCupFileLogging logsDir = do
let logfile = logsDir </> "ghcup.log"
liftIO $ do
createDirRecursive' logsDir
createDirectoryIfMissing True logsDir
logFiles <- findFiles
logsDir
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
createRegularFile newFilePerms logfile
writeFile logfile ""
pure logfile

7
lib/GHCup/Utils/MegaParsec.hs
View File

@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Utils.MegaParsec where
@@ -23,6 +23,7 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Versions
import Data.Void
import System.FilePath
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
@@ -117,3 +118,7 @@ verP suffix = do
v <- versioning'
MP.setInput rest
pure v
pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators

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

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -12,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
GHCup specific prelude. Lots of Excepts functionality.
-}
@@ -25,6 +26,8 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub )
import Data.Foldable
import Data.String
import Data.Text ( Text )
import Data.Versions
@@ -32,7 +35,14 @@ import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import System.IO.Unsafe
import System.Directory
import System.FilePath
#if defined(IS_WINDOWS)
import Control.Retry
import GHC.IO.Exception
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
@@ -242,6 +252,8 @@ throwEither' e eth = case eth of
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
verToS :: Version -> String
verToS = T.unpack . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
@@ -252,14 +264,6 @@ removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO getEnvironment
pure (adds ++ cEnv)
pvpToVersion :: PVP -> Version
pvpToVersion =
either (\_ -> error "Couldn't convert PVP to Version") id
@@ -284,3 +288,139 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- pathIsSymbolicLink p
case ft of
True -> do
rp <- canonicalizePath p
rft <- doesDirectoryExist rp
case rft of
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
where
collect files dirs' [] = return (reverse files
,reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
rmPath :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmPath fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
]
(\_ -> liftIO $ removePathForcibly fp)
#else
liftIO $ removeDirectoryRecursive fp
#endif
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
rmFile :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmFile fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | Strip @\\r@ and @\\n@ from 'ByteString's
stripNewline :: String -> String
stripNewline s
| null s = []
| head s `elem` "\n\r" = stripNewline (tail s)
| otherwise = head s : stripNewline (tail s)
isNewLine :: Word8 -> Bool
isNewLine w
| w == _lf = True
| w == _cr = True
| otherwise = False

2
lib/GHCup/Utils/String/QQ.hs
View File

@@ -7,7 +7,7 @@ Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufel
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
QuasiQuoter for non-interpolated strings, texts and bytestrings.

2
lib/GHCup/Utils/Version/QQ.hs
View File

@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Utils.Version.QQ where

4
lib/GHCup/Version.hs
View File

@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Version where
@@ -25,7 +25,7 @@ import qualified Data.Text as T
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.4.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.5.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP