Restructure modules
This commit is contained in:
@@ -99,9 +99,6 @@ module GHCup.Utils.Dirs
|
||||
, setAccessTime
|
||||
, setModificationTime
|
||||
, isSymbolicLink
|
||||
|
||||
-- uhm
|
||||
, rmPathForcibly
|
||||
)
|
||||
where
|
||||
|
||||
@@ -110,11 +107,15 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Prelude.MegaParsec
|
||||
import GHCup.Prelude.File.Search
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Prelude.Logger.Internal (logWarn, logDebug)
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Prelude.Windows ( isWindows )
|
||||
#else
|
||||
import GHCup.Prelude.Posix ( isWindows )
|
||||
#endif
|
||||
|
||||
import Control.DeepSeq (NFData, rnf)
|
||||
import Control.Exception.Safe
|
||||
@@ -147,6 +148,7 @@ import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Yaml.Aeson as Y
|
||||
import qualified Text.Megaparsec as MP
|
||||
import System.IO.Error (ioeGetErrorType)
|
||||
|
||||
|
||||
|
||||
@@ -371,10 +373,15 @@ ghcupConfigFile :: (MonadIO m)
|
||||
=> Excepts '[JSONError] m UserSettings
|
||||
ghcupConfigFile = do
|
||||
filepath <- getConfigFilePath
|
||||
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
|
||||
contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
|
||||
case contents of
|
||||
Nothing -> pure defaultUserSettings
|
||||
Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
|
||||
Just contents' -> liftE
|
||||
. veitherToExcepts @_ @'[JSONError]
|
||||
. either (VLeft . V) VRight
|
||||
. first (JSONDecodeError . displayException)
|
||||
. Y.decodeEither'
|
||||
$ contents'
|
||||
|
||||
|
||||
-------------------------
|
||||
@@ -411,6 +418,12 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
|
||||
parseGHCupHLSDir (T.pack -> fp) =
|
||||
throwEither $ MP.parse version' "" fp
|
||||
|
||||
-- TODO: inlined from GHCup.Prelude
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
throwEither a = case a of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
-- | ~/.ghcup/hls by default, for new-style installs.
|
||||
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
||||
ghcupHLSBaseDir = do
|
||||
@@ -459,7 +472,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
|
||||
(\fp ->
|
||||
handleIO (\e -> run
|
||||
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
|
||||
. rmPathForcibly
|
||||
. removePathForcibly
|
||||
$ fp))
|
||||
|
||||
|
||||
@@ -522,13 +535,5 @@ removePathForcibly :: GHCupPath -> IO ()
|
||||
removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
|
||||
|
||||
|
||||
rmPathForcibly :: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupPath
|
||||
-> m ()
|
||||
rmPathForcibly fp
|
||||
| isWindows = recover (liftIO $ removePathForcibly fp)
|
||||
| otherwise = liftIO $ removePathForcibly fp
|
||||
|
||||
|
||||
|
||||
@@ -1,340 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.Utils.File (
|
||||
mergeFileTree,
|
||||
copyFileE,
|
||||
findFilesDeep,
|
||||
getDirectoryContentsRecursive,
|
||||
getDirectoryContentsRecursiveBFS,
|
||||
getDirectoryContentsRecursiveDFS,
|
||||
getDirectoryContentsRecursiveUnsafe,
|
||||
getDirectoryContentsRecursiveBFSUnsafe,
|
||||
getDirectoryContentsRecursiveDFSUnsafe,
|
||||
recordedInstallationFile,
|
||||
module GHCup.Utils.File.Common,
|
||||
|
||||
executeOut,
|
||||
execLogged,
|
||||
exec,
|
||||
toProcessError,
|
||||
chmod_755,
|
||||
isBrokenSymlink,
|
||||
copyFile,
|
||||
deleteFile,
|
||||
install,
|
||||
removeEmptyDirectory,
|
||||
removeDirIfEmptyOrIsSymlink,
|
||||
removeEmptyDirsRecursive,
|
||||
rmFileForce,
|
||||
createDirRecursive',
|
||||
recyclePathForcibly,
|
||||
rmDirectory,
|
||||
recycleFile,
|
||||
rmFile,
|
||||
rmDirectoryLink,
|
||||
moveFilePortable,
|
||||
moveFile
|
||||
) where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
#if IS_WINDOWS
|
||||
import GHCup.Utils.File.Windows
|
||||
#else
|
||||
import GHCup.Utils.File.Posix
|
||||
#endif
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Text.Regex.Posix
|
||||
import Control.Exception.Safe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Control.Monad.Reader
|
||||
import System.FilePath
|
||||
import Text.PrettyPrint.HughesPJClass (prettyShow)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Streamly.Prelude as S
|
||||
import Control.DeepSeq (force)
|
||||
import Control.Exception (evaluate)
|
||||
import GHC.IO.Exception
|
||||
import System.IO.Error
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
|
||||
-- | Merge one file tree to another given a copy operation.
|
||||
--
|
||||
-- Records every successfully installed file into the destination
|
||||
-- returned by 'recordedInstallationFile'.
|
||||
--
|
||||
-- If any copy operation fails, the record file is deleted, as well
|
||||
-- as the partially installed files.
|
||||
mergeFileTree :: ( MonadMask m
|
||||
, S.MonadAsync m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, MonadCatch m
|
||||
)
|
||||
=> GHCupPath -- ^ source base directory from which to install findFiles
|
||||
-> InstallDirResolved -- ^ destination base dir
|
||||
-> Tool
|
||||
-> GHCTargetVersion
|
||||
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
||||
-> Excepts '[MergeFileTreeError] m ()
|
||||
mergeFileTree _ (GHCupBinDir fp) _ _ _ =
|
||||
throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
|
||||
mergeFileTree sourceBase destBase tool v' copyOp = do
|
||||
lift $ logInfo $ "Merging file tree from \""
|
||||
<> T.pack (fromGHCupPath sourceBase)
|
||||
<> "\" to \""
|
||||
<> T.pack (fromInstallDir destBase)
|
||||
<> "\""
|
||||
recFile <- recordedInstallationFile tool v'
|
||||
|
||||
wrapInExcepts $ do
|
||||
-- These checks are not atomic, but we perform them to have
|
||||
-- the opportunity to abort before copying has started.
|
||||
--
|
||||
-- The actual copying might still fail.
|
||||
liftIO $ baseCheck (fromGHCupPath sourceBase)
|
||||
liftIO $ destCheck (fromInstallDir destBase)
|
||||
|
||||
-- we only record for non-isolated installs
|
||||
when (isSafeDir destBase) $ do
|
||||
whenM (liftIO $ doesFileExist recFile)
|
||||
$ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
|
||||
liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
|
||||
|
||||
-- we want the cleanup action to leak through in case of exception
|
||||
onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do
|
||||
logDebug "Starting merge"
|
||||
lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
|
||||
copy f
|
||||
logDebug $ T.pack "Recording installed file: " <> T.pack f
|
||||
recordInstalledFile f recFile
|
||||
pure f
|
||||
|
||||
where
|
||||
wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))
|
||||
|
||||
cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do
|
||||
(force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO
|
||||
(readFile recFile >>= evaluate)
|
||||
logDebug "Deleting recorded files due to partial install"
|
||||
forM_ l $ \f -> do
|
||||
let dest = fromInstallDir destBase </> dropDrive f
|
||||
logDebug $ "rm -f " <> T.pack f
|
||||
hideError NoSuchThing $ rmFile dest
|
||||
pure ()
|
||||
logDebug $ "rm -f " <> T.pack recFile
|
||||
hideError NoSuchThing $ rmFile recFile
|
||||
logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)
|
||||
hideError UnsatisfiedConstraints $ hideError NoSuchThing $
|
||||
removeEmptyDirsRecursive (fromInstallDir destBase)
|
||||
|
||||
|
||||
recordInstalledFile f recFile = when (isSafeDir destBase) $
|
||||
liftIO $ appendFile recFile (f <> "\n")
|
||||
|
||||
copy source = do
|
||||
let dest = fromInstallDir destBase </> source
|
||||
src = fromGHCupPath sourceBase </> source
|
||||
|
||||
when (isAbsolute source)
|
||||
$ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
|
||||
|
||||
liftIO . createDirectoryIfMissing True . takeDirectory $ dest
|
||||
|
||||
copyOp src dest
|
||||
|
||||
|
||||
baseCheck src = do
|
||||
when (isRelative src)
|
||||
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
|
||||
whenM (not <$> doesDirectoryExist src)
|
||||
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
|
||||
destCheck dest = do
|
||||
when (isRelative dest)
|
||||
$ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
|
||||
|
||||
|
||||
|
||||
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
|
||||
copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
|
||||
|
||||
|
||||
-- | 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.
|
||||
--
|
||||
-- depth first
|
||||
getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
||||
=> GHCupPath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
|
||||
|
||||
-- breadth first
|
||||
getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
||||
=> GHCupPath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
|
||||
|
||||
|
||||
getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
||||
=> GHCupPath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
|
||||
|
||||
getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
|
||||
|
||||
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
|
||||
findFilesDeep path regex =
|
||||
S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
|
||||
|
||||
|
||||
recordedInstallationFile :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
)
|
||||
=> Tool
|
||||
-> GHCTargetVersion
|
||||
-> m FilePath
|
||||
recordedInstallationFile t v' = do
|
||||
Dirs {..} <- getDirs
|
||||
pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
|
||||
|
||||
removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
removeDirIfEmptyOrIsSymlink filepath =
|
||||
hideError UnsatisfiedConstraints $
|
||||
handleIO' InappropriateType
|
||||
(handleIfSym filepath)
|
||||
(liftIO $ removeEmptyDirectory filepath)
|
||||
where
|
||||
handleIfSym fp e = do
|
||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||
if isSym
|
||||
then rmFileForce fp
|
||||
else liftIO $ ioError e
|
||||
|
||||
removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
removeEmptyDirsRecursive = go
|
||||
where
|
||||
go fp = do
|
||||
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
|
||||
forM_ cs go
|
||||
liftIO $ removeEmptyDirectory fp
|
||||
|
||||
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
|
||||
rmFileForce filepath = do
|
||||
hideError doesNotExistErrorType
|
||||
$ hideError InappropriateType $ rmFile filepath
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
-- https://github.com/haskell/directory/issues/110
|
||||
-- https://github.com/haskell/directory/issues/96
|
||||
-- https://www.sqlite.org/src/info/89f1848d7f
|
||||
recyclePathForcibly :: ( MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupPath
|
||||
-> m ()
|
||||
recyclePathForcibly fp
|
||||
| isWindows = do
|
||||
Dirs { recycleDir } <- getDirs
|
||||
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
|
||||
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
|
||||
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
|
||||
`catch`
|
||||
(\e -> if | isDoesNotExistError e -> pure ()
|
||||
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
|
||||
| otherwise -> throwIO e)
|
||||
`finally`
|
||||
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
||||
| otherwise = liftIO $ removePathForcibly fp
|
||||
|
||||
|
||||
|
||||
rmDirectory :: (MonadIO m, MonadMask m)
|
||||
=> GHCupPath
|
||||
-> m ()
|
||||
rmDirectory fp
|
||||
| isWindows = recover (liftIO $ removeDirectory fp)
|
||||
| otherwise = liftIO $ removeDirectory fp
|
||||
|
||||
|
||||
-- https://www.sqlite.org/src/info/89f1848d7f
|
||||
-- https://github.com/haskell/directory/issues/96
|
||||
recycleFile :: ( MonadIO m
|
||||
, MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
recycleFile fp
|
||||
| isWindows = do
|
||||
Dirs { recycleDir } <- getDirs
|
||||
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
|
||||
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
|
||||
let dest = fromGHCupPath tmp </> takeFileName fp
|
||||
liftIO (moveFile fp dest)
|
||||
`catch`
|
||||
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
|
||||
`finally`
|
||||
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
||||
| otherwise = liftIO $ removeFile fp
|
||||
|
||||
|
||||
rmFile :: ( MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmFile fp
|
||||
| isWindows = recover (liftIO $ removeFile fp)
|
||||
| otherwise = liftIO $ removeFile fp
|
||||
|
||||
|
||||
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmDirectoryLink fp
|
||||
| isWindows = recover (liftIO $ removeDirectoryLink fp)
|
||||
| otherwise = liftIO $ removeDirectoryLink fp
|
||||
@@ -1,14 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module GHCup.Utils.File (
|
||||
recycleFile
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Reader (MonadReader)
|
||||
import GHCup.Types.Optics (HasDirs)
|
||||
|
||||
|
||||
recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
|
||||
|
||||
@@ -1,112 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module GHCup.Utils.File.Common (
|
||||
module GHCup.Utils.File.Common
|
||||
, ProcessError(..)
|
||||
, CapturedProcess(..)
|
||||
) where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types(ProcessError(..), CapturedProcess(..))
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
import Data.Void
|
||||
import GHC.IO.Exception
|
||||
import System.Directory hiding ( removeDirectory
|
||||
, removeDirectoryRecursive
|
||||
, removePathForcibly
|
||||
, findFiles
|
||||
)
|
||||
import System.FilePath
|
||||
import Text.Regex.Posix
|
||||
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
-- | Follows the first match in case of Regex.
|
||||
expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
|
||||
expandFilePath = go ""
|
||||
where
|
||||
go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]
|
||||
go p [] = pure [p]
|
||||
go p (x:xs) = do
|
||||
case x of
|
||||
Left s -> go (p </> s) xs
|
||||
Right regex -> do
|
||||
fps <- findFiles p regex
|
||||
res <- forM fps $ \fp -> go (p </> fp) xs
|
||||
pure $ mconcat res
|
||||
|
||||
|
||||
findFiles :: FilePath -> Regex -> IO [FilePath]
|
||||
findFiles path regex = do
|
||||
contents <- listDirectory path
|
||||
pure $ filter (match regex) contents
|
||||
|
||||
|
||||
findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
|
||||
findFiles' path parser = do
|
||||
contents <- listDirectory path
|
||||
pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents
|
||||
|
||||
|
||||
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
|
||||
checkFileAlreadyExists fp = liftIO $ doesFileExist fp
|
||||
|
||||
|
||||
@@ -1,5 +0,0 @@
|
||||
module GHCup.Utils.File.Common where
|
||||
|
||||
import Text.Regex.Posix
|
||||
|
||||
findFiles :: FilePath -> Regex -> IO [FilePath]
|
||||
@@ -1,645 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE CApiFFI #-}
|
||||
|
||||
{-|
|
||||
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.Dirs
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.File.Posix.Traversals
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import qualified Control.Exception as E
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
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.List
|
||||
import Data.Word8
|
||||
import Foreign.C.String
|
||||
import Foreign.C.Error
|
||||
import Foreign.C.Types
|
||||
import GHC.IO.Exception
|
||||
import System.IO ( stderr, hClose, hSetBinaryMode )
|
||||
import System.IO.Error hiding ( catchIOError )
|
||||
import System.FilePath
|
||||
import System.Posix.Directory
|
||||
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
||||
import System.Posix.Internals ( withFilePath )
|
||||
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.Directory as PD
|
||||
import qualified System.Posix.Files as PF
|
||||
import qualified System.Posix.Process as SPP
|
||||
import qualified System.Posix.IO as SPI
|
||||
import qualified System.Console.Terminal.Size as TP
|
||||
import qualified System.Posix as Posix
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.FileSystem.Handle
|
||||
as IFH
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified GHCup.Utils.File.Posix.Foreign as FD
|
||||
import qualified Streamly.Internal.Data.Stream.StreamD.Type
|
||||
as D
|
||||
import Streamly.Internal.Data.Unfold.Type
|
||||
import qualified Streamly.Internal.Data.Unfold as U
|
||||
import Streamly.Internal.Control.Concurrent ( withRunInIO )
|
||||
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
|
||||
|
||||
|
||||
|
||||
-- | 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 env m
|
||||
, HasSettings env
|
||||
, HasLog env
|
||||
, HasDirs env
|
||||
, 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
|
||||
Settings {..} <- getSettings
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let logfile = fromGHCupPath logsDir </> lfile <> ".log"
|
||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||
closeFd
|
||||
(action verbose noColor)
|
||||
where
|
||||
action verbose no_color 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 no_color
|
||||
)
|
||||
(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 = readTilEOF lineAction
|
||||
|
||||
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 -> Bool -> IO ()
|
||||
printToRegion fileFd fdIn size pState no_color = do
|
||||
-- init region
|
||||
forM_ [1..size] $ \_ -> BS.hPut stderr "\n"
|
||||
|
||||
void $ flip runStateT mempty
|
||||
$ do
|
||||
handle
|
||||
(\(ex :: SomeException) -> do
|
||||
ps <- liftIO $ takeMVar pState
|
||||
when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))
|
||||
throw ex
|
||||
) $ readTilEOF lineAction fdIn
|
||||
|
||||
where
|
||||
clearScreen :: ByteString
|
||||
clearScreen = "\x1b[0J"
|
||||
clearLine :: ByteString
|
||||
clearLine = "\x1b[2K"
|
||||
moveLineUp :: Int -> ByteString
|
||||
moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"
|
||||
moveLineDown :: Int -> ByteString
|
||||
moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"
|
||||
pos1 :: ByteString
|
||||
pos1 = "\r"
|
||||
overwriteNthLine :: Int -> ByteString -> ByteString
|
||||
overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
|
||||
|
||||
blue :: ByteString -> ByteString
|
||||
blue bs
|
||||
| no_color = bs
|
||||
| otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
|
||||
|
||||
-- action to perform line by line
|
||||
lineAction :: (MonadMask m, MonadIO m)
|
||||
=> ByteString
|
||||
-> StateT (Seq ByteString) m ()
|
||||
lineAction = \bs' -> do
|
||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
modify (swapRegs bs')
|
||||
liftIO TP.size >>= \case
|
||||
Nothing -> pure ()
|
||||
Just (TP.Window _ w) -> do
|
||||
regs <- get
|
||||
liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
|
||||
BS.hPut stderr
|
||||
. overwriteNthLine (size - i)
|
||||
. trim w
|
||||
. blue
|
||||
. (\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 $ E.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 :: (MonadReader env m, HasLog env, 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 ("chmod 755 " <> T.pack 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
|
||||
|
||||
copyFile :: FilePath -- ^ source file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if file exists
|
||||
-> IO ()
|
||||
copyFile from to fail' = do
|
||||
bracket
|
||||
(openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
|
||||
(hClose . snd)
|
||||
$ \(fromFd, fH) -> do
|
||||
sourceFileMode <- fileMode <$> getFdStatus fromFd
|
||||
let dflags = [ FD.oNofollow
|
||||
, if fail' then FD.oExcl else FD.oTrunc
|
||||
]
|
||||
bracket
|
||||
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
|
||||
(hClose . snd)
|
||||
$ \(_, tH) -> do
|
||||
hSetBinaryMode fH True
|
||||
hSetBinaryMode tH True
|
||||
streamlyCopy (fH, tH)
|
||||
where
|
||||
openFdHandle fp omode flags fM = do
|
||||
fd <- openFd' fp omode flags fM
|
||||
handle' <- SPI.fdToHandle fd
|
||||
pure (fd, handle')
|
||||
streamlyCopy (fH, tH) =
|
||||
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
|
||||
|
||||
foreign import capi unsafe "fcntl.h open"
|
||||
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
|
||||
|
||||
|
||||
open_ :: CString
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags]
|
||||
-> Maybe Posix.FileMode
|
||||
-> IO Posix.Fd
|
||||
open_ str how optional_flags maybe_mode = do
|
||||
fd <- c_open str all_flags mode_w
|
||||
return (Posix.Fd fd)
|
||||
where
|
||||
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
|
||||
|
||||
|
||||
(creat, mode_w) = case maybe_mode of
|
||||
Nothing -> ([],0)
|
||||
Just x -> ([FD.oCreat], x)
|
||||
|
||||
open_mode = case how of
|
||||
Posix.ReadOnly -> FD.oRdonly
|
||||
Posix.WriteOnly -> FD.oWronly
|
||||
Posix.ReadWrite -> FD.oRdwr
|
||||
|
||||
|
||||
-- |Open and optionally create this file. See 'System.Posix.Files'
|
||||
-- for information on how to use the 'FileMode' type.
|
||||
--
|
||||
-- Note that passing @Just x@ as the 4th argument triggers the
|
||||
-- `oCreat` status flag, which must be set when you pass in `oExcl`
|
||||
-- to the status flags. Also see the manpage for @open(2)@.
|
||||
openFd' :: FilePath
|
||||
-> Posix.OpenMode
|
||||
-> [FD.Flags] -- ^ status flags of @open(2)@
|
||||
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
|
||||
-> IO Posix.Fd
|
||||
openFd' name how optional_flags maybe_mode =
|
||||
withFilePath name $ \str ->
|
||||
throwErrnoPathIfMinus1Retry "openFd" name $
|
||||
open_ str how optional_flags maybe_mode
|
||||
|
||||
|
||||
-- |Deletes the given file. Raises `eISDIR`
|
||||
-- if run on a directory. Does not follow symbolic links.
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InappropriateType` for wrong file type (directory)
|
||||
-- - `NoSuchThing` if the file does not exist
|
||||
-- - `PermissionDenied` if the directory cannot be read
|
||||
--
|
||||
-- Notes: calls `unlink`
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile = removeLink
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
--
|
||||
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
||||
--
|
||||
-- Safety/reliability concerns:
|
||||
--
|
||||
-- * `Overwrite` mode is inherently non-atomic
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
||||
-- - `PermissionDenied` if output directory cannot be written to
|
||||
-- - `PermissionDenied` if source directory cannot be opened
|
||||
-- - `SameFile` if source and destination are the same file
|
||||
-- (`HPathIOException`)
|
||||
--
|
||||
--
|
||||
-- Throws in `Strict` mode only:
|
||||
--
|
||||
-- - `AlreadyExists` if destination already exists
|
||||
--
|
||||
-- Throws in `Overwrite` mode only:
|
||||
--
|
||||
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
||||
--
|
||||
-- Notes:
|
||||
--
|
||||
-- - calls `symlink`
|
||||
recreateSymlink :: FilePath -- ^ the old symlink file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if destination file exists
|
||||
-> IO ()
|
||||
recreateSymlink symsource newsym fail' = do
|
||||
sympoint <- readSymbolicLink symsource
|
||||
case fail' of
|
||||
True -> pure ()
|
||||
False ->
|
||||
hideError doesNotExistErrorType $ deleteFile newsym
|
||||
createSymbolicLink sympoint newsym
|
||||
|
||||
|
||||
-- copys files, recreates symlinks, fails on all other types
|
||||
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||
install from to fail' = do
|
||||
fs <- PF.getSymbolicLinkStatus from
|
||||
decide fs
|
||||
where
|
||||
decide fs | PF.isRegularFile fs = copyFile from to fail'
|
||||
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
||||
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
||||
|
||||
moveFile :: FilePath -> FilePath -> IO ()
|
||||
moveFile = rename
|
||||
|
||||
|
||||
moveFilePortable :: FilePath -> FilePath -> IO ()
|
||||
moveFilePortable from to = do
|
||||
catchErrno [eXDEV] (moveFile from to) $ do
|
||||
copyFile from to True
|
||||
removeFile from
|
||||
|
||||
|
||||
catchErrno :: [Errno] -- ^ errno to catch
|
||||
-> IO a -- ^ action to try, which can raise an IOException
|
||||
-> IO a -- ^ action to carry out in case of an IOException and
|
||||
-- if errno matches
|
||||
-> IO a
|
||||
catchErrno en a1 a2 =
|
||||
catchIOError a1 $ \e -> do
|
||||
errno <- getErrno
|
||||
if errno `elem` en
|
||||
then a2
|
||||
else ioError e
|
||||
|
||||
removeEmptyDirectory :: FilePath -> IO ()
|
||||
removeEmptyDirectory = PD.removeDirectory
|
||||
|
||||
|
||||
-- | Create an 'Unfold' of directory contents.
|
||||
unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
|
||||
unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step dirstream = do
|
||||
(typ, e) <- liftIO $ readDirEnt dirstream
|
||||
return $ if
|
||||
| null e -> D.Stop
|
||||
| "." == e -> D.Skip dirstream
|
||||
| ".." == e -> D.Skip dirstream
|
||||
| otherwise -> D.Yield (typ, e) dirstream
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
|
||||
where
|
||||
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
|
||||
if | t == FD.dtDir -> go (cd </> f)
|
||||
| otherwise -> pure (cd </> f)
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath
|
||||
getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step (_, Nothing, []) = return D.Stop
|
||||
|
||||
step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
|
||||
(dt, f) <- liftIO $ readDirEnt dirstream
|
||||
if | FD.dtUnknown == dt -> do
|
||||
runIOFinalizer finalizer
|
||||
return $ D.Skip (topdir, Nothing, dirs)
|
||||
| f == "." || f == ".."
|
||||
-> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
| FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)
|
||||
| otherwise -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)
|
||||
|
||||
step (topdir, Nothing, dir:dirs) = do
|
||||
(s, f) <- acquire (topdir </> dir)
|
||||
return $ D.Skip (topdir, Just (dir, s, f), dirs)
|
||||
|
||||
acquire dir =
|
||||
withRunInIO $ \run -> mask_ $ run $ do
|
||||
dirstream <- liftIO $ openDirStream dir
|
||||
ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
|
||||
return (dirstream, ref)
|
||||
|
||||
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
|
||||
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module GHCup.Utils.File.Posix.Foreign where
|
||||
|
||||
import Data.Bits
|
||||
import Data.List (foldl')
|
||||
import Foreign.C.Types
|
||||
|
||||
#include <limits.h>
|
||||
#include <stdlib.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <fcntl.h>
|
||||
|
||||
newtype DirType = DirType Int deriving (Eq, Show)
|
||||
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
|
||||
|
||||
unFlags :: Flags -> Int
|
||||
unFlags (Flags i) = i
|
||||
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
|
||||
|
||||
-- |Returns @True@ if posix-paths was compiled with support for the provided
|
||||
-- flag. (As of this writing, the only flag for which this check may be
|
||||
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
|
||||
isSupported :: Flags -> Bool
|
||||
isSupported (Flags _) = True
|
||||
isSupported _ = False
|
||||
|
||||
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
|
||||
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
|
||||
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
|
||||
-- throw an exception.)
|
||||
oCloexec :: Flags
|
||||
#ifdef O_CLOEXEC
|
||||
oCloexec = Flags #{const O_CLOEXEC}
|
||||
#else
|
||||
{-# WARNING oCloexec
|
||||
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
|
||||
oCloexec = UnsupportedFlag "O_CLOEXEC"
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
-- If these enum declarations occur earlier in the file, haddock
|
||||
-- gets royally confused about the above doc comments.
|
||||
-- Probably http://trac.haskell.org/haddock/ticket/138
|
||||
|
||||
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
|
||||
|
||||
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
|
||||
|
||||
pathMax :: Int
|
||||
pathMax = #{const PATH_MAX}
|
||||
|
||||
unionFlags :: [Flags] -> CInt
|
||||
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0
|
||||
|
||||
@@ -1,92 +0,0 @@
|
||||
{-# LANGUAGE CApiFFI #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
|
||||
module GHCup.Utils.File.Posix.Traversals (
|
||||
-- lower-level stuff
|
||||
readDirEnt
|
||||
, unpackDirStream
|
||||
) where
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import GHCup.Utils.File.Posix.Foreign
|
||||
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
import Foreign.C.Error
|
||||
import Foreign.C.String
|
||||
import Foreign.C.Types
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable
|
||||
import System.Posix
|
||||
import Foreign (alloca)
|
||||
import System.Posix.Internals (peekFilePath)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------------------------------------
|
||||
-- dodgy stuff
|
||||
|
||||
type CDir = ()
|
||||
type CDirent = ()
|
||||
|
||||
-- Posix doesn't export DirStream, so to re-use that type we need to use
|
||||
-- unsafeCoerce. It's just a newtype, so this is a legitimate usage.
|
||||
-- ugly trick.
|
||||
unpackDirStream :: DirStream -> Ptr CDir
|
||||
unpackDirStream = unsafeCoerce
|
||||
|
||||
-- the __hscore_* functions are defined in the unix package. We can import them and let
|
||||
-- the linker figure it out.
|
||||
foreign import ccall unsafe "__hscore_readdir"
|
||||
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
|
||||
|
||||
foreign import ccall unsafe "__hscore_free_dirent"
|
||||
c_freeDirEnt :: Ptr CDirent -> IO ()
|
||||
|
||||
foreign import ccall unsafe "__hscore_d_name"
|
||||
c_name :: Ptr CDirent -> IO CString
|
||||
|
||||
foreign import ccall unsafe "__posixdir_d_type"
|
||||
c_type :: Ptr CDirent -> IO DirType
|
||||
|
||||
----------------------------------------------------------
|
||||
-- less dodgy but still lower-level
|
||||
|
||||
|
||||
readDirEnt :: DirStream -> IO (DirType, FilePath)
|
||||
readDirEnt (unpackDirStream -> dirp) =
|
||||
alloca $ \ptr_dEnt -> loop ptr_dEnt
|
||||
where
|
||||
loop ptr_dEnt = do
|
||||
resetErrno
|
||||
r <- c_readdir dirp ptr_dEnt
|
||||
if r == 0
|
||||
then do
|
||||
dEnt <- peek ptr_dEnt
|
||||
if dEnt == nullPtr
|
||||
then return (dtUnknown, mempty)
|
||||
else do
|
||||
dName <- c_name dEnt >>= peekFilePath
|
||||
dType <- c_type dEnt
|
||||
c_freeDirEnt dEnt
|
||||
return (dType, dName)
|
||||
else do
|
||||
errno <- getErrno
|
||||
if errno == eINTR
|
||||
then loop ptr_dEnt
|
||||
else do
|
||||
let (Errno eo) = errno
|
||||
if eo == 0
|
||||
then return (dtUnknown, mempty)
|
||||
else throwErrno "readDirEnt"
|
||||
|
||||
@@ -1,520 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
{-|
|
||||
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.Utils.Logger
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
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 qualified GHC.Unicode as U
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import qualified System.IO.Error as IOE
|
||||
import System.Process
|
||||
|
||||
import qualified System.Win32.Info as WS
|
||||
import qualified System.Win32.File as WS
|
||||
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
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Streamly.Internal.Data.Stream.StreamD.Type
|
||||
as D
|
||||
import Streamly.Internal.Data.Unfold.Type hiding ( concatMap )
|
||||
import Data.Bits ((.&.))
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified Streamly.Internal.Data.Unfold as U
|
||||
import Streamly.Internal.Control.Concurrent ( withRunInIO )
|
||||
import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )
|
||||
|
||||
|
||||
|
||||
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 env m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
, HasSettings env
|
||||
, 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
|
||||
Dirs {..} <- getDirs
|
||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||
let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = fromGHCupPath 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
|
||||
-- subprocess stdout also goes to stderr for logging
|
||||
void $ BS.hPut stderr 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
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
execShell :: 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 ())
|
||||
execShell exe args chdir env = do
|
||||
let cmd = exe <> " " <> concatMap (' ':) args
|
||||
cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
|
||||
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
|
||||
pure $ toProcessError cmd [] 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
|
||||
msys2Dir <- liftIO ghcupMsys2Dir
|
||||
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
|
||||
let mingWPaths = [msys2Dir </> "usr" </> "bin"
|
||||
,msys2Dir </> "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 }
|
||||
|
||||
ghcupMsys2Dir :: IO FilePath
|
||||
ghcupMsys2Dir =
|
||||
lookupEnv "GHCUP_MSYS2" >>= \case
|
||||
Just fp -> pure fp
|
||||
Nothing -> do
|
||||
baseDir <- liftIO ghcupBaseDir
|
||||
pure (fromGHCupPath baseDir </> "msys64")
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
copyFile :: FilePath -- ^ source file
|
||||
-> FilePath -- ^ destination file
|
||||
-> Bool -- ^ fail if file exists
|
||||
-> IO ()
|
||||
copyFile = WS.copyFile
|
||||
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile = WS.deleteFile
|
||||
|
||||
|
||||
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||
install = copyFile
|
||||
|
||||
|
||||
moveFile :: FilePath -> FilePath -> IO ()
|
||||
moveFile from to = WS.moveFileEx from (Just to) 0
|
||||
|
||||
|
||||
moveFilePortable :: FilePath -> FilePath -> IO ()
|
||||
moveFilePortable = WS.moveFile
|
||||
|
||||
|
||||
removeEmptyDirectory :: FilePath -> IO ()
|
||||
removeEmptyDirectory = WS.removeDirectory
|
||||
|
||||
|
||||
unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath)
|
||||
unfoldDirContents = U.bracket alloc dealloc (Unfold step return)
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step (_, False, _, _) = return D.Stop
|
||||
step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do
|
||||
f <- liftIO $ WS.getFindDataFileName fd
|
||||
more <- liftIO $ WS.findNextFile h fd
|
||||
|
||||
-- can't get file attribute from FindData yet (needs Win32 PR)
|
||||
fattr <- liftIO $ WS.getFileAttributes (topdir </> f)
|
||||
|
||||
if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd)
|
||||
| otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd)
|
||||
|
||||
alloc topdir = do
|
||||
query <- liftIO $ furnishPath (topdir </> "*")
|
||||
(h, fd) <- liftIO $ WS.findFirstFile query
|
||||
pure (topdir, True, h, fd)
|
||||
|
||||
dealloc (_, _, fd, _) = liftIO $ WS.findClose fd
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t)
|
||||
=> FilePath
|
||||
-> t m FilePath
|
||||
getDirectoryContentsRecursiveDFSUnsafe fp = go ""
|
||||
where
|
||||
isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
|
||||
|
||||
go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->
|
||||
if | isDir t -> go (cd </> f)
|
||||
| otherwise -> pure (cd </> f)
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath
|
||||
getDirectoryContentsRecursiveUnfold = Unfold step init'
|
||||
where
|
||||
{-# INLINE [0] step #-}
|
||||
step (_, Nothing, []) = return D.Stop
|
||||
|
||||
step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do
|
||||
f <- liftIO $ WS.getFindDataFileName findData
|
||||
|
||||
more <- liftIO $ WS.findNextFile h findData
|
||||
when (not more) $ runIOFinalizer ref
|
||||
let nextState = if more then state else Nothing
|
||||
|
||||
-- can't get file attribute from FindData yet (needs Win32 PR)
|
||||
fattr <- liftIO $ WS.getFileAttributes (topdir </> cdir </> f)
|
||||
|
||||
if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs)
|
||||
| isDir fattr -> return $ D.Skip (topdir, nextState, (cdir </> f):dirs)
|
||||
| otherwise -> return $ D.Yield (cdir </> f) (topdir, nextState, dirs)
|
||||
|
||||
step (topdir, Nothing, dir:dirs) = do
|
||||
(h, findData, ref) <- acquire (topdir </> dir)
|
||||
return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs)
|
||||
|
||||
init' topdir = do
|
||||
(h, findData, ref) <- acquire topdir
|
||||
return (topdir, Just ("", (h, findData, ref)), [])
|
||||
|
||||
isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0
|
||||
|
||||
acquire dir = do
|
||||
query <- liftIO $ furnishPath (dir </> "*")
|
||||
withRunInIO $ \run -> mask_ $ run $ do
|
||||
(h, findData) <- liftIO $ WS.findFirstFile query
|
||||
ref <- newIOFinalizer (liftIO $ WS.findClose h)
|
||||
return (h, findData, ref)
|
||||
|
||||
|
||||
getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
|
||||
=> FilePath
|
||||
-> S.SerialT m FilePath
|
||||
getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold
|
||||
|
||||
|
||||
|
||||
--------------------------------------
|
||||
--[ Inlined from directory package ]--
|
||||
--------------------------------------
|
||||
|
||||
|
||||
furnishPath :: FilePath -> IO FilePath
|
||||
furnishPath path =
|
||||
(toExtendedLengthPath <$> rawPrependCurrentDirectory path)
|
||||
`IOE.catchIOError` \ _ ->
|
||||
pure path
|
||||
|
||||
|
||||
toExtendedLengthPath :: FilePath -> FilePath
|
||||
toExtendedLengthPath path
|
||||
| isRelative path = simplifiedPath
|
||||
| otherwise =
|
||||
case simplifiedPath of
|
||||
'\\' : '?' : '?' : '\\' : _ -> simplifiedPath
|
||||
'\\' : '\\' : '?' : '\\' : _ -> simplifiedPath
|
||||
'\\' : '\\' : '.' : '\\' : _ -> simplifiedPath
|
||||
'\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
|
||||
_ -> "\\\\?\\" <> simplifiedPath
|
||||
where simplifiedPath = simplify path
|
||||
|
||||
|
||||
simplify :: FilePath -> FilePath
|
||||
simplify = simplifyWindows
|
||||
|
||||
simplifyWindows :: FilePath -> FilePath
|
||||
simplifyWindows "" = ""
|
||||
simplifyWindows path =
|
||||
case drive' of
|
||||
"\\\\?\\" -> drive' <> subpath
|
||||
_ -> simplifiedPath
|
||||
where
|
||||
simplifiedPath = joinDrive drive' subpath'
|
||||
(drive, subpath) = splitDrive path
|
||||
drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
|
||||
subpath' = appendSep . avoidEmpty . prependSep . joinPath .
|
||||
stripPardirs . expandDots . skipSeps .
|
||||
splitDirectories $ subpath
|
||||
|
||||
upperDrive d = case d of
|
||||
c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s
|
||||
_ -> d
|
||||
skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
|
||||
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
|
||||
| otherwise = id
|
||||
prependSep | subpathIsAbsolute = (pathSeparator :)
|
||||
| otherwise = id
|
||||
avoidEmpty | not pathIsAbsolute
|
||||
&& (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
|
||||
= emptyToCurDir
|
||||
| otherwise = id
|
||||
appendSep p | hasTrailingPathSep
|
||||
&& not (pathIsAbsolute && null p)
|
||||
= addTrailingPathSeparator p
|
||||
| otherwise = p
|
||||
pathIsAbsolute = not (isRelative path)
|
||||
subpathIsAbsolute = any isPathSeparator (take 1 subpath)
|
||||
hasTrailingPathSep = hasTrailingPathSeparator subpath
|
||||
|
||||
emptyToCurDir :: FilePath -> FilePath
|
||||
emptyToCurDir "" = "."
|
||||
emptyToCurDir path = path
|
||||
|
||||
normaliseTrailingSep :: FilePath -> FilePath
|
||||
normaliseTrailingSep path = do
|
||||
let path' = reverse path
|
||||
let (sep, path'') = span isPathSeparator path'
|
||||
let addSep = if null sep then id else (pathSeparator :)
|
||||
reverse (addSep path'')
|
||||
|
||||
normalisePathSeps :: FilePath -> FilePath
|
||||
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
|
||||
|
||||
expandDots :: [FilePath] -> [FilePath]
|
||||
expandDots = reverse . go []
|
||||
where
|
||||
go ys' xs' =
|
||||
case xs' of
|
||||
[] -> ys'
|
||||
x : xs ->
|
||||
case x of
|
||||
"." -> go ys' xs
|
||||
".." ->
|
||||
case ys' of
|
||||
[] -> go (x : ys') xs
|
||||
".." : _ -> go (x : ys') xs
|
||||
_ : ys -> go ys xs
|
||||
_ -> go (x : ys') xs
|
||||
|
||||
rawPrependCurrentDirectory :: FilePath -> IO FilePath
|
||||
rawPrependCurrentDirectory path
|
||||
| isRelative path =
|
||||
((`ioeAddLocation` "prependCurrentDirectory") .
|
||||
(`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do
|
||||
getFullPathName path
|
||||
| otherwise = pure path
|
||||
|
||||
ioeAddLocation :: IOError -> String -> IOError
|
||||
ioeAddLocation e loc = do
|
||||
IOE.ioeSetLocation e newLoc
|
||||
where
|
||||
newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
|
||||
oldLoc = IOE.ioeGetLocation e
|
||||
|
||||
getFullPathName :: FilePath -> IO FilePath
|
||||
getFullPathName path =
|
||||
fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)
|
||||
|
||||
fromExtendedLengthPath :: FilePath -> FilePath
|
||||
fromExtendedLengthPath ePath =
|
||||
case ePath of
|
||||
'\\' : '\\' : '?' : '\\' : path ->
|
||||
case path of
|
||||
'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath
|
||||
drive : ':' : subpath
|
||||
-- if the path is not "regular", then the prefix is necessary
|
||||
-- to ensure the path is interpreted literally
|
||||
| U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path
|
||||
_ -> ePath
|
||||
_ -> ePath
|
||||
where
|
||||
isPathRegular path =
|
||||
not ('/' `elem` path ||
|
||||
"." `elem` splitDirectories path ||
|
||||
".." `elem` splitDirectories path)
|
||||
@@ -1,132 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Logger
|
||||
Description : logger definition
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
Here we define our main logger.
|
||||
-}
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
|
||||
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
|
||||
import {-# SOURCE #-} GHCup.Utils.File (recycleFile)
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Data.Text ( Text )
|
||||
import Optics
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Console.Pretty
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import GHCup.Utils.Prelude
|
||||
import qualified Data.Text as T
|
||||
|
||||
logInfo :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
logInfo = logInternal Info
|
||||
|
||||
logWarn :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
logWarn = logInternal Warn
|
||||
|
||||
logDebug :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
logDebug = logInternal Debug
|
||||
|
||||
logError :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
logError = logInternal Error
|
||||
|
||||
|
||||
logInternal :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
) => LogLevel
|
||||
-> Text
|
||||
-> m ()
|
||||
logInternal logLevel msg = do
|
||||
LoggerConfig {..} <- gets @"loggerConfig"
|
||||
let color' c = if fancyColors then color c else id
|
||||
let style' = case logLevel of
|
||||
Debug -> style Bold . color' Blue
|
||||
Info -> style Bold . color' Green
|
||||
Warn -> style Bold . color' Yellow
|
||||
Error -> style Bold . color' Red
|
||||
let l = case logLevel of
|
||||
Debug -> style' "[ Debug ]"
|
||||
Info -> style' "[ Info ]"
|
||||
Warn -> style' "[ Warn ]"
|
||||
Error -> style' "[ Error ]"
|
||||
let strs = T.split (== '\n') msg
|
||||
let out = case strs of
|
||||
[] -> T.empty
|
||||
(x:xs) ->
|
||||
foldr (\a b -> a <> "\n" <> b) mempty
|
||||
. ((l <> " " <> x) :)
|
||||
. fmap (\line' -> style' "[ ... ] " <> line' )
|
||||
$ xs
|
||||
|
||||
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
|
||||
$ liftIO $ consoleOutter out
|
||||
|
||||
-- raw output
|
||||
let lr = case logLevel of
|
||||
Debug -> "Debug:"
|
||||
Info -> "Info:"
|
||||
Warn -> "Warn:"
|
||||
Error -> "Error:"
|
||||
let outr = lr <> " " <> msg <> "\n"
|
||||
liftIO $ fileOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
) => m FilePath
|
||||
initGHCupFileLogging = do
|
||||
Dirs { logsDir } <- getDirs
|
||||
let logfile = fromGHCupPath logsDir </> "ghcup.log"
|
||||
logFiles <- liftIO $ findFiles
|
||||
(fromGHCupPath logsDir)
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^.*\.log$|] :: B.ByteString)
|
||||
)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
|
||||
|
||||
liftIO $ writeFile logfile ""
|
||||
pure logfile
|
||||
@@ -1,19 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Data.Text ( Text )
|
||||
import Optics
|
||||
|
||||
logWarn :: ( MonadReader env m
|
||||
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
|
||||
, MonadIO m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
|
||||
@@ -1,124 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.MegaParsec
|
||||
Description : MegaParsec utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.MegaParsec where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Applicative
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Data.Functor
|
||||
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
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
|
||||
choice' [] = fail "Empty list"
|
||||
choice' [x ] = x
|
||||
choice' (x : xs) = MP.try x <|> choice' xs
|
||||
|
||||
|
||||
parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
|
||||
parseUntil p = do
|
||||
(MP.try (MP.lookAhead p) $> mempty)
|
||||
<|> (do
|
||||
c <- T.singleton <$> MP.anySingle
|
||||
c2 <- parseUntil p
|
||||
pure (c `mappend` c2)
|
||||
)
|
||||
|
||||
parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
|
||||
parseUntil1 p = do
|
||||
i1 <- MP.getOffset
|
||||
t <- parseUntil p
|
||||
i2 <- MP.getOffset
|
||||
if i1 == i2 then fail "empty parse" else pure t
|
||||
|
||||
|
||||
|
||||
-- | Parses e.g.
|
||||
-- * armv7-unknown-linux-gnueabihf-ghc
|
||||
-- * armv7-unknown-linux-gnueabihf-ghci
|
||||
ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
|
||||
ghcTargetBinP t =
|
||||
(,)
|
||||
<$> ( MP.try
|
||||
(Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
|
||||
)
|
||||
<|> ((\ _ x -> x) Nothing <$> mempty)
|
||||
)
|
||||
<*> (MP.chunk t <* MP.eof)
|
||||
|
||||
|
||||
-- | Extracts the version from @ProjectVersion="8.10.5"@.
|
||||
ghcProjectVersion :: MP.Parsec Void Text Version
|
||||
ghcProjectVersion = do
|
||||
_ <- MP.chunk "ProjectVersion=\""
|
||||
ver <- parseUntil1 $ MP.chunk "\""
|
||||
MP.setInput ver
|
||||
version'
|
||||
|
||||
|
||||
-- | Extracts target triple and version from e.g.
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
||||
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
|
||||
ghcTargetVerP =
|
||||
(\x y -> GHCTargetVersion x y)
|
||||
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
|
||||
<|> ((\ _ x -> x) Nothing <$> mempty)
|
||||
)
|
||||
<*> (version' <* MP.eof)
|
||||
where
|
||||
verP' :: MP.Parsec Void Text Text
|
||||
verP' = do
|
||||
v <- version'
|
||||
let startsWithDigists =
|
||||
and
|
||||
. take 3
|
||||
. concatMap
|
||||
(map
|
||||
(\case
|
||||
(Digits _) -> True
|
||||
(Str _) -> False
|
||||
) . NE.toList)
|
||||
. NE.toList
|
||||
$ _vChunks v
|
||||
if startsWithDigists && isNothing (_vEpoch v)
|
||||
then pure $ prettyVer v
|
||||
else fail "Oh"
|
||||
|
||||
|
||||
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
|
||||
verP suffix = do
|
||||
ver <- parseUntil suffix
|
||||
if T.null ver
|
||||
then fail "empty version"
|
||||
else do
|
||||
rest <- MP.getInput
|
||||
MP.setInput ver
|
||||
v <- versioning'
|
||||
MP.setInput rest
|
||||
pure v
|
||||
|
||||
|
||||
pathSep :: MP.Parsec Void Text Char
|
||||
pathSep = MP.oneOf pathSeparators
|
||||
@@ -1,14 +0,0 @@
|
||||
module GHCup.Utils.Posix where
|
||||
|
||||
|
||||
-- | Enables ANSI support on windows, does nothing on unix.
|
||||
--
|
||||
-- Returns 'Left str' on errors and 'Right bool' on success, where
|
||||
-- 'bool' markes whether ansi support was already enabled.
|
||||
--
|
||||
-- This function never crashes.
|
||||
--
|
||||
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
|
||||
enableAnsiSupport :: IO (Either String Bool)
|
||||
enableAnsiSupport = pure (Right True)
|
||||
|
||||
@@ -1,602 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Prelude
|
||||
Description : MegaParsec utilities
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
-}
|
||||
module GHCup.Utils.Prelude
|
||||
(module GHCup.Utils.Prelude,
|
||||
#if defined(IS_WINDOWS)
|
||||
module GHCup.Utils.Prelude.Windows
|
||||
#else
|
||||
module GHCup.Utils.Prelude.Posix
|
||||
#endif
|
||||
)
|
||||
where
|
||||
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
|
||||
import GHCup.Types
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Utils.Prelude.Windows
|
||||
#else
|
||||
import GHCup.Utils.Prelude.Posix
|
||||
#endif
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
|
||||
import Data.Maybe
|
||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8 hiding ( isDigit )
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
||||
import System.IO.Error
|
||||
import System.Directory hiding ( removeDirectory
|
||||
, removeDirectoryRecursive
|
||||
, removePathForcibly
|
||||
, copyFile
|
||||
)
|
||||
import System.FilePath
|
||||
|
||||
import Control.Retry
|
||||
import GHC.IO.Exception
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.List.Split as Split
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Encoding.Error as E
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as B
|
||||
import qualified Data.Text.Lazy.Builder.Int as B
|
||||
import qualified Data.Text.Lazy.Encoding as TLE
|
||||
|
||||
|
||||
|
||||
-- $setup
|
||||
-- >>> import Data.ByteString.Internal (c2w, w2c)
|
||||
-- >>> import Test.QuickCheck
|
||||
-- >>> import Data.Word8
|
||||
-- >>> import qualified Data.Text as T
|
||||
-- >>> import qualified Data.Char as C
|
||||
-- >>> import Data.List
|
||||
-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
|
||||
|
||||
|
||||
fS :: IsString a => String -> a
|
||||
fS = fromString
|
||||
|
||||
fromStrictMaybe :: S.Maybe a -> Maybe a
|
||||
fromStrictMaybe = S.maybe Nothing Just
|
||||
|
||||
fSM :: S.Maybe a -> Maybe a
|
||||
fSM = fromStrictMaybe
|
||||
|
||||
toStrictMaybe :: Maybe a -> S.Maybe a
|
||||
toStrictMaybe = maybe S.Nothing S.Just
|
||||
|
||||
tSM :: Maybe a -> S.Maybe a
|
||||
tSM = toStrictMaybe
|
||||
|
||||
internalError :: String -> IO a
|
||||
internalError = fail . ("Internal error: " <>)
|
||||
|
||||
iE :: String -> IO a
|
||||
iE = internalError
|
||||
|
||||
|
||||
showT :: Show a => a -> Text
|
||||
showT = fS . show
|
||||
|
||||
-- | Like 'when', but where the test can be monadic.
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
whenM ~b ~t = ifM b t (return ())
|
||||
|
||||
-- | Like 'unless', but where the test can be monadic.
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM ~b ~f = ifM b (return ()) f
|
||||
|
||||
-- | Like @if@, but where the test can be monadic.
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ~b ~t ~f = do
|
||||
b' <- b
|
||||
if b' then t else f
|
||||
|
||||
whileM :: Monad m => m a -> (a -> m Bool) -> m a
|
||||
whileM ~action ~f = do
|
||||
a <- action
|
||||
b' <- f a
|
||||
if b' then whileM action f else pure a
|
||||
|
||||
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||
whileM_ ~action = void . whileM action
|
||||
|
||||
guardM :: (Monad m, Alternative m) => m Bool -> m ()
|
||||
guardM ~f = guard =<< f
|
||||
|
||||
|
||||
handleIO' :: (MonadIO m, MonadCatch m)
|
||||
=> IOErrorType
|
||||
-> (IOException -> m a)
|
||||
-> m a
|
||||
-> m a
|
||||
handleIO' err handler = handleIO
|
||||
(\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
|
||||
|
||||
|
||||
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
|
||||
(??) m e = maybe (throwE e) pure m
|
||||
|
||||
|
||||
(!?) :: forall e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> m (Maybe a)
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
(!?) em e = lift em >>= (?? e)
|
||||
|
||||
|
||||
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
|
||||
lE = liftE . veitherToExcepts . fromEither
|
||||
|
||||
lE' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> Either e' a
|
||||
-> Excepts es m a
|
||||
lE' f = liftE . veitherToExcepts . fromEither . first f
|
||||
|
||||
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
|
||||
lEM em = lift em >>= lE
|
||||
|
||||
lEM' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> m (Either e' a)
|
||||
-> Excepts es m a
|
||||
lEM' f em = lift em >>= lE . first f
|
||||
|
||||
-- for some obscure reason... this won't type-check if we move it to a different module
|
||||
catchWarn :: forall es m env . ( Pretty (V es)
|
||||
, MonadReader env m
|
||||
, HasLog env
|
||||
, MonadIO m
|
||||
, Monad m) => Excepts es m () -> Excepts '[] m ()
|
||||
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
|
||||
|
||||
fromEither :: Either a b -> VEither '[a] b
|
||||
fromEither = either (VLeft . V) VRight
|
||||
|
||||
|
||||
liftIOException' :: ( MonadCatch m
|
||||
, MonadIO m
|
||||
, Monad m
|
||||
, e :< es'
|
||||
, LiftVariant es es'
|
||||
)
|
||||
=> IOErrorType
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
liftIOException' errType ex =
|
||||
handleIO
|
||||
(\e ->
|
||||
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
|
||||
)
|
||||
. liftE
|
||||
|
||||
|
||||
liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
|
||||
=> IOErrorType
|
||||
-> e
|
||||
-> m a
|
||||
-> Excepts es' m a
|
||||
liftIOException errType ex =
|
||||
handleIO
|
||||
(\e ->
|
||||
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
|
||||
)
|
||||
. lift
|
||||
|
||||
|
||||
-- | Uses safe-exceptions.
|
||||
hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
|
||||
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
|
||||
|
||||
|
||||
hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
|
||||
hideErrorDef errs def =
|
||||
handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
|
||||
|
||||
|
||||
hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
|
||||
hideErrorDefM errs def =
|
||||
handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
|
||||
|
||||
|
||||
-- TODO: does this work?
|
||||
hideExcept :: forall e es es' a m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> a
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
hideExcept _ a =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
|
||||
|
||||
|
||||
hideExcept' :: forall e es es' m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
hideExcept' _ =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
|
||||
|
||||
|
||||
reThrowAll :: forall e es es' a m
|
||||
. (Monad m, e :< es')
|
||||
=> (V es -> e)
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
reThrowAll f = catchAllE (throwE . f)
|
||||
|
||||
|
||||
reThrowAllIO :: forall e es es' a m
|
||||
. (MonadCatch m, Monad m, MonadIO m, e :< es')
|
||||
=> (V es -> e)
|
||||
-> (IOException -> e)
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
|
||||
|
||||
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
throwEither a = case a of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
|
||||
throwEither' e eth = case eth of
|
||||
Left _ -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
|
||||
throwMaybe a m = case m of
|
||||
Nothing -> throwM a
|
||||
Just r -> pure r
|
||||
|
||||
throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
|
||||
throwMaybeM a am = do
|
||||
m <- am
|
||||
throwMaybe a m
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
|
||||
pvpToVersion pvp_ rest =
|
||||
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
|
||||
|
||||
-- | Convert a version to a PVP and unparsable rest.
|
||||
--
|
||||
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
|
||||
versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
|
||||
versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
|
||||
versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v
|
||||
where
|
||||
alternative :: MonadThrow m => Version -> m PVP
|
||||
alternative v' = case NE.takeWhile isDigit (_vChunks v') of
|
||||
[] -> throwM $ ParseError "Couldn't convert Version to PVP"
|
||||
xs -> pure $ pvpFromList (unsafeDigit <$> xs)
|
||||
|
||||
rest :: Version -> Text
|
||||
rest (Version _ cs pr me) =
|
||||
let chunks = NE.dropWhile isDigit cs
|
||||
ver = intersperse (T.pack ".") . chunksAsT $ chunks
|
||||
me' = maybe [] (\m -> [T.pack "+",m]) me
|
||||
pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
|
||||
prefix = case (ver, pr', me') of
|
||||
(_:_, _, _) -> T.pack "."
|
||||
_ -> T.pack ""
|
||||
in prefix <> mconcat (ver <> pr' <> me')
|
||||
where
|
||||
chunksAsT :: Functor t => t VChunk -> t Text
|
||||
chunksAsT = fmap (foldMap f)
|
||||
where
|
||||
f :: VUnit -> Text
|
||||
f (Digits i) = T.pack $ show i
|
||||
f (Str s) = s
|
||||
|
||||
foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
|
||||
foldable d g f | null f = d
|
||||
| otherwise = g f
|
||||
|
||||
|
||||
|
||||
isDigit :: VChunk -> Bool
|
||||
isDigit (Digits _ :| []) = True
|
||||
isDigit _ = False
|
||||
|
||||
unsafeDigit :: VChunk -> Int
|
||||
unsafeDigit (Digits x :| []) = fromIntegral x
|
||||
unsafeDigit _ = error "unsafeDigit: wrong input"
|
||||
|
||||
pvpFromList :: [Int] -> PVP
|
||||
pvpFromList = PVP . NE.fromList . fmap fromIntegral
|
||||
|
||||
-- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
|
||||
-- the Unicode replacement character U+FFFD.
|
||||
decUTF8Safe :: ByteString -> Text
|
||||
decUTF8Safe = E.decodeUtf8With E.lenientDecode
|
||||
|
||||
decUTF8Safe' :: L.ByteString -> Text
|
||||
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
|
||||
|
||||
|
||||
-- | Escape a version for use in regex
|
||||
escapeVerRex :: Version -> ByteString
|
||||
escapeVerRex = B.pack . go . B.unpack . verToBS
|
||||
where
|
||||
go [] = []
|
||||
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
|
||||
| otherwise = x : go xs
|
||||
|
||||
|
||||
|
||||
recover :: (MonadIO m, MonadMask m) => m a -> m a
|
||||
recover action =
|
||||
recovering (fullJitterBackoff 25000 <> limitRetries 10)
|
||||
[\_ -> Handler (\e -> pure $ isPermissionError e)
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
|
||||
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
|
||||
]
|
||||
(\_ -> action)
|
||||
|
||||
|
||||
-- | Gathering monoidal values
|
||||
--
|
||||
-- >>> traverseFold (pure . (:["0"])) ["1","2"]
|
||||
-- ["1","0","2","0"]
|
||||
-- >>> traverseFold Just ["1","2","3","4","5"]
|
||||
-- Just "12345"
|
||||
--
|
||||
-- prop> \t -> traverseFold Just t === Just (mconcat t)
|
||||
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 'String's
|
||||
--
|
||||
-- >>> stripNewline "foo\n\n\n"
|
||||
-- "foo"
|
||||
-- >>> stripNewline "foo\n\n\nfoo"
|
||||
-- "foofoo"
|
||||
-- >>> stripNewline "foo\r"
|
||||
-- "foo"
|
||||
-- >>> stripNewline "foo"
|
||||
-- "foo"
|
||||
--
|
||||
-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
|
||||
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
|
||||
stripNewline :: String -> String
|
||||
stripNewline = filter (`notElem` "\n\r")
|
||||
|
||||
|
||||
-- | Strip @\\r@ and @\\n@ from end of 'String'.
|
||||
--
|
||||
-- >>> stripNewlineEnd "foo\n\n\n"
|
||||
-- "foo"
|
||||
-- >>> stripNewlineEnd "foo\n\n\nfoo"
|
||||
-- "foo\n\n\nfoo"
|
||||
-- >>> stripNewlineEnd "foo\r"
|
||||
-- "foo"
|
||||
-- >>> stripNewlineEnd "foo"
|
||||
-- "foo"
|
||||
--
|
||||
-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
|
||||
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
|
||||
stripNewlineEnd :: String -> String
|
||||
stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
|
||||
|
||||
|
||||
-- | Strip @\\r@ and @\\n@ from 'Text's
|
||||
--
|
||||
-- >>> stripNewline' "foo\n\n\n"
|
||||
-- "foo"
|
||||
-- >>> stripNewline' "foo\n\n\nfoo"
|
||||
-- "foofoo"
|
||||
-- >>> stripNewline' "foo\r"
|
||||
-- "foo"
|
||||
-- >>> stripNewline' "foo"
|
||||
-- "foo"
|
||||
--
|
||||
-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
|
||||
-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
|
||||
stripNewline' :: T.Text -> T.Text
|
||||
stripNewline' = T.filter (`notElem` "\n\r")
|
||||
|
||||
|
||||
-- | Is the word8 a newline?
|
||||
--
|
||||
-- >>> isNewLine (c2w '\n')
|
||||
-- True
|
||||
-- >>> isNewLine (c2w '\r')
|
||||
-- True
|
||||
--
|
||||
-- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)
|
||||
isNewLine :: Word8 -> Bool
|
||||
isNewLine w
|
||||
| w == _lf = True
|
||||
| w == _cr = True
|
||||
| otherwise = False
|
||||
|
||||
|
||||
-- | Split on a PVP suffix.
|
||||
--
|
||||
-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"
|
||||
-- ("ghc-iserv-dyn","9.3.20210706")
|
||||
-- >>> splitOnPVP "-" "ghc-iserv-dyn"
|
||||
-- ("ghc-iserv-dyn","")
|
||||
splitOnPVP :: String -> String -> (String, String)
|
||||
splitOnPVP c s = case Split.splitOn c s of
|
||||
[] -> def
|
||||
[_] -> def
|
||||
xs
|
||||
| let l = last xs
|
||||
, (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
|
||||
| otherwise -> def
|
||||
where
|
||||
def = (s, "")
|
||||
|
||||
|
||||
|
||||
-- | Like 'find', but where the test can be monadic.
|
||||
--
|
||||
-- >>> findM (Just . C.isUpper) "teST"
|
||||
-- Just (Just 'S')
|
||||
-- >>> findM (Just . C.isUpper) "test"
|
||||
-- Just Nothing
|
||||
-- >>> findM (Just . const True) ["x",undefined]
|
||||
-- Just (Just "x")
|
||||
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
|
||||
findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
|
||||
|
||||
|
||||
-- | Drops the given suffix from a list.
|
||||
-- It returns the original sequence if the sequence doesn't end with the given suffix.
|
||||
--
|
||||
-- >>> dropSuffix "!" "Hello World!"
|
||||
-- "Hello World"
|
||||
-- >>> dropSuffix "!" "Hello World!!"
|
||||
-- "Hello World!"
|
||||
-- >>> dropSuffix "!" "Hello World."
|
||||
-- "Hello World."
|
||||
dropSuffix :: Eq a => [a] -> [a] -> [a]
|
||||
dropSuffix a b = fromMaybe b $ stripSuffix a b
|
||||
|
||||
-- | Return the prefix of the second list if its suffix
|
||||
-- matches the entire first list.
|
||||
--
|
||||
-- >>> stripSuffix "bar" "foobar"
|
||||
-- Just "foo"
|
||||
-- >>> stripSuffix "" "baz"
|
||||
-- Just "baz"
|
||||
-- >>> stripSuffix "foo" "quux"
|
||||
-- Nothing
|
||||
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
|
||||
stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)
|
||||
|
||||
|
||||
-- | Drops the given prefix from a list.
|
||||
-- It returns the original sequence if the sequence doesn't start with the given prefix.
|
||||
--
|
||||
-- >>> dropPrefix "Mr. " "Mr. Men"
|
||||
-- "Men"
|
||||
-- >>> dropPrefix "Mr. " "Dr. Men"
|
||||
-- "Dr. Men"
|
||||
dropPrefix :: Eq a => [a] -> [a] -> [a]
|
||||
dropPrefix a b = fromMaybe b $ stripPrefix a b
|
||||
|
||||
|
||||
|
||||
-- | Break a list into pieces separated by the first
|
||||
-- list argument, consuming the delimiter. An empty delimiter is
|
||||
-- invalid, and will cause an error to be raised.
|
||||
--
|
||||
-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
|
||||
-- ["a","b","d","e"]
|
||||
-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"
|
||||
-- ["","X","X","X",""]
|
||||
-- >>> splitOn "x" "x"
|
||||
-- ["",""]
|
||||
-- >>> splitOn "x" ""
|
||||
-- [""]
|
||||
--
|
||||
-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
|
||||
-- prop> \c x -> splitOn [c] x == split (==c) x
|
||||
splitOn :: Eq a => [a] -> [a] -> [[a]]
|
||||
splitOn [] _ = error "splitOn, needle may not be empty"
|
||||
splitOn _ [] = [[]]
|
||||
splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b
|
||||
where (a,b) = breakOn needle haystack
|
||||
|
||||
|
||||
-- | Splits a list into components delimited by separators,
|
||||
-- where the predicate returns True for a separator element. The
|
||||
-- resulting components do not contain the separators. Two adjacent
|
||||
-- separators result in an empty component in the output.
|
||||
--
|
||||
-- >>> split (== 'a') "aabbaca"
|
||||
-- ["","","bb","c",""]
|
||||
-- >>> split (== 'a') ""
|
||||
-- [""]
|
||||
-- >>> split (== ':') "::xyz:abc::123::"
|
||||
-- ["","","xyz","abc","","123","",""]
|
||||
-- >>> split (== ',') "my,list,here"
|
||||
-- ["my","list","here"]
|
||||
split :: (a -> Bool) -> [a] -> [[a]]
|
||||
split _ [] = [[]]
|
||||
split f (x:xs)
|
||||
| f x = [] : split f xs
|
||||
| y:ys <- split f xs = (x:y) : ys
|
||||
| otherwise = [[]]
|
||||
|
||||
|
||||
-- | Find the first instance of @needle@ in @haystack@.
|
||||
-- The first element of the returned tuple
|
||||
-- is the prefix of @haystack@ before @needle@ is matched. The second
|
||||
-- is the remainder of @haystack@, starting with the match.
|
||||
-- If you want the remainder /without/ the match, use 'stripInfix'.
|
||||
--
|
||||
-- >>> breakOn "::" "a::b::c"
|
||||
-- ("a","::b::c")
|
||||
-- >>> breakOn "/" "foobar"
|
||||
-- ("foobar","")
|
||||
--
|
||||
-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
|
||||
breakOn :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
|
||||
breakOn _ [] = ([], [])
|
||||
breakOn needle (x:xs) = first (x:) $ breakOn needle xs
|
||||
@@ -1,8 +0,0 @@
|
||||
module GHCup.Utils.Prelude.Posix where
|
||||
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = False
|
||||
isNotWindows = not isWindows
|
||||
|
||||
|
||||
@@ -1,6 +0,0 @@
|
||||
module GHCup.Utils.Prelude.Windows where
|
||||
|
||||
isWindows, isNotWindows :: Bool
|
||||
isWindows = True
|
||||
isNotWindows = not isWindows
|
||||
|
||||
@@ -1,57 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.String.QQ
|
||||
Description : String quasi quoters
|
||||
Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
|
||||
QuasiQuoter for non-interpolated strings, texts and bytestrings.
|
||||
|
||||
The "s" quoter contains a multi-line string with no interpolation at all,
|
||||
except that the leading newline is trimmed and carriage returns stripped.
|
||||
|
||||
@
|
||||
{-\# LANGUAGE QuasiQuotes #-}
|
||||
import Data.Text (Text)
|
||||
import Data.String.QQ
|
||||
foo :: Text -- "String", "ByteString" etc also works
|
||||
foo = [s|
|
||||
Well here is a
|
||||
multi-line string!
|
||||
|]
|
||||
@
|
||||
|
||||
Any instance of the IsString type is permitted.
|
||||
|
||||
(For GHC versions 6, write "[$s||]" instead of "[s||]".)
|
||||
|
||||
-}
|
||||
module GHCup.Utils.String.QQ
|
||||
( s
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Data.Char
|
||||
import GHC.Exts ( IsString(..) )
|
||||
import Language.Haskell.TH.Quote
|
||||
|
||||
-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
|
||||
-- The pattern portion is undefined.
|
||||
s :: QuasiQuoter
|
||||
s = QuasiQuoter
|
||||
(\s' -> case all isAscii s' of
|
||||
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
|
||||
False -> fail "Not ascii"
|
||||
)
|
||||
(error "Cannot use s as a pattern")
|
||||
(error "Cannot use s as a type")
|
||||
(error "Cannot use s as a dec")
|
||||
where
|
||||
removeCRs = filter (/= '\r')
|
||||
trimLeadingNewline ('\n' : xs) = xs
|
||||
trimLeadingNewline xs = xs
|
||||
@@ -1,107 +0,0 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.Version.QQ
|
||||
Description : Version quasi-quoters
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.Version.QQ where
|
||||
|
||||
import Data.Data
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import GHC.Base
|
||||
#endif
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH.Syntax ( Lift
|
||||
, dataToExpQ
|
||||
)
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
|
||||
|
||||
deriving instance Data Versioning
|
||||
deriving instance Lift Versioning
|
||||
deriving instance Data Version
|
||||
deriving instance Lift Version
|
||||
deriving instance Data SemVer
|
||||
deriving instance Lift SemVer
|
||||
deriving instance Data Mess
|
||||
deriving instance Lift Mess
|
||||
deriving instance Data MChunk
|
||||
deriving instance Lift MChunk
|
||||
deriving instance Data PVP
|
||||
deriving instance Lift PVP
|
||||
deriving instance Lift VSep
|
||||
deriving instance Data VSep
|
||||
deriving instance Lift VUnit
|
||||
deriving instance Data VUnit
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
deriving instance Lift (NonEmpty Word)
|
||||
deriving instance Lift (NonEmpty VChunk)
|
||||
deriving instance Lift (NonEmpty MChunk)
|
||||
deriving instance Lift (NonEmpty VUnit)
|
||||
#endif
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' = QuasiQuoter
|
||||
{ quoteExp = \s -> quoteExp' . T.pack $ s
|
||||
, quotePat = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
|
||||
, quoteDec = \_ -> fail
|
||||
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
|
||||
vver :: QuasiQuoter
|
||||
vver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . version
|
||||
|
||||
mver :: QuasiQuoter
|
||||
mver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . mess
|
||||
|
||||
sver :: QuasiQuoter
|
||||
sver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . semver
|
||||
|
||||
vers :: QuasiQuoter
|
||||
vers = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . versioning
|
||||
|
||||
pver :: QuasiQuoter
|
||||
pver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . pvp
|
||||
|
||||
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
|
||||
liftText :: T.Text -> Q Exp
|
||||
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
|
||||
|
||||
liftDataWithText :: Data a => a -> Q Exp
|
||||
liftDataWithText = dataToExpQ (fmap liftText . cast)
|
||||
@@ -1,48 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module GHCup.Utils.Windows where
|
||||
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Data.Bits
|
||||
|
||||
import System.Win32.Console
|
||||
import System.Win32.File hiding ( copyFile )
|
||||
import System.Win32.Types
|
||||
|
||||
|
||||
|
||||
|
||||
-- | Enables ANSI support on windows, does nothing on unix.
|
||||
--
|
||||
-- Returns 'Left str' on errors and 'Right bool' on success, where
|
||||
-- 'bool' markes whether ansi support was already enabled.
|
||||
--
|
||||
-- This function never crashes.
|
||||
--
|
||||
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
|
||||
enableAnsiSupport :: IO (Either String Bool)
|
||||
enableAnsiSupport = handleIO (pure . Left . displayException) $ do
|
||||
-- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
|
||||
-- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
|
||||
h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
|
||||
fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
|
||||
when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
|
||||
|
||||
-- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
|
||||
m <- getConsoleMode h
|
||||
|
||||
-- VT processing not already enabled?
|
||||
if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
|
||||
-- https://docs.microsoft.com/en-us/windows/console/setconsolemode
|
||||
then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
|
||||
>> pure (Right False)
|
||||
else pure (Right True)
|
||||
|
||||
Reference in New Issue
Block a user