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

Lala

Browse Source
This commit is contained in:
Julian Ospald
2020-03-05 18:02:59 +01:00
parent 718442a1e7
commit 2d51ad8940
19 changed files with 635 additions and 307 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
lib/GHCup/Utils/Dirs.hs Normal file
View File

@@ -0,0 +1,92 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Dirs where
import GHCup.Types.JSON ( )
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Maybe
import Data.Versions
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
-------------------------
--[ GHCup directories ]--
-------------------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
--[ Others ]--
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess

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

@@ -3,19 +3,17 @@
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.String.QQ
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
@@ -27,28 +25,23 @@ import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.IO
import System.Posix.Directory.ByteString
import System.Posix.Env.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString
import System.Posix.Types
import qualified System.Posix.Process.ByteString
as SPPB
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy as L
@@ -115,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
let logfile = ldir </> lfile
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo fd stdOutput
-- dup stderr
void $ dupTo fd stdError
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- | 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.
@@ -193,27 +216,6 @@ toProcessError exe args mps = case mps of
Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath

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

@@ -1,28 +1,59 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Logger where
import GHCup.Utils
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.IO.Error
import qualified Data.ByteString as B
import qualified Data.ByteString as B
data LoggerConfig = LoggerConfig {
lcPrintDebug :: Bool
, outter :: B.ByteString -> IO ()
}
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let l = case level of
LevelDebug -> if lcPrintDebug then toLogStr (style Bold $ color Blue "[ Debug ]") else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelDebug -> if lcPrintDebug
then toLogStr (style Bold $ color Blue "[ Debug ]")
else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
outter out
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug: "
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

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

@@ -1,15 +1,10 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Utils.Prelude where
@@ -21,20 +16,12 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Data
import Data.Monoid ( (<>) )
import Data.String
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import System.IO.Error
import qualified Data.ByteString.Lazy as L
@@ -45,7 +32,6 @@ 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
import qualified Language.Haskell.TH.Syntax as TH
@@ -197,84 +183,20 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
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 PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
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 (\a -> liftText <$> cast a)
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

48
lib/GHCup/Utils/String/QQ.hs Normal file
View File

@@ -0,0 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
-- | 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 and $ fmap isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

89
lib/GHCup/Utils/Version/QQ.hs Normal file
View File

@@ -0,0 +1,89 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.Version.QQ where
import Data.Data
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, 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 PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
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 (\a -> liftText <$> cast a)