Initial commit
This commit is contained in:
686
lib/GHCup.hs
Normal file
686
lib/GHCup.hs
Normal file
@@ -0,0 +1,686 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module GHCup where
|
||||
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Utils.Version.QQ
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( getSearchPath )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Tool installation ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
|
||||
installGHCBin :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
installGHCBin bDls ver mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC ver)
|
||||
$ (throwE $ AlreadyInstalled GHC ver)
|
||||
Settings {..} <- lift ask
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed archiveSubdir es)
|
||||
)
|
||||
$ installGHC' archiveSubdir ghcdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
liftE $ postGHCInstall ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
|
||||
installGHC' :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installGHC' path inst = do
|
||||
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
|
||||
lEM $ liftIO $ execLogged [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath inst]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
pure ()
|
||||
|
||||
|
||||
installCabalBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBin bDls ver mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
Settings {..} <- lift ask
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installCabal' archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) [s|Installing cabal|]
|
||||
let cabalFile = [rel|cabal|] :: Path Rel
|
||||
liftIO $ createDirIfMissing newDirPerms inst
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(inst </> cabalFile)
|
||||
Overwrite
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Set GHC ]--
|
||||
---------------
|
||||
|
||||
|
||||
|
||||
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
|
||||
-- on `SetGHC`:
|
||||
--
|
||||
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
--
|
||||
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
||||
-- for `SetGHCOnly` constructor.
|
||||
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setGHC ver sghc = do
|
||||
let verBS = verToBS ver
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- symlink destination
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
|
||||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
case sghc of
|
||||
SetGHCOnly -> liftE $ rmPlain ver
|
||||
SetGHC_XY -> lift $ rmMajorSymlinks ver
|
||||
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
forM_ verfiles $ \file -> do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
|
||||
targetFile <- case sghc of
|
||||
SetGHCOnly -> pure file
|
||||
SetGHC_XY -> do
|
||||
major' <-
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
|
||||
-- create symlink
|
||||
let fullF = bindir </> targetFile
|
||||
let destL = ghcLinkDestination (toFilePath file) ver
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
|
||||
liftIO $ createSymlink fullF destL
|
||||
|
||||
-- create symlink for share dir
|
||||
lift $ symlinkShareDir ghcdir verBS
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadIO m, MonadLogger m)
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
destdir <- liftIO $ ghcupBaseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|] :: Path Rel
|
||||
let fullsharedir = ghcdir </> sharedir
|
||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||
let fullF = destdir </> sharedir
|
||||
let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
|
||||
$(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
||||
liftIO $ createSymlink fullF targetF
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ List tools ]--
|
||||
------------------
|
||||
|
||||
|
||||
data ListCriteria = ListInstalled
|
||||
| ListSet
|
||||
deriving Show
|
||||
|
||||
data ListResult = ListResult
|
||||
{ lTool :: Tool
|
||||
, lVer :: Version
|
||||
, lTag :: [Tag]
|
||||
, lInstalled :: Bool
|
||||
, lSet :: Bool
|
||||
, fromSrc :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
|
||||
availableToolVersions av tool = toListOf
|
||||
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
|
||||
av
|
||||
|
||||
|
||||
listVersions :: GHCupDownloads
|
||||
-> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> IO [ListResult]
|
||||
listVersions av lt criteria = case lt of
|
||||
Just t -> do
|
||||
filter' <$> forM (availableToolVersions av t) (toListResult t)
|
||||
Nothing -> do
|
||||
ghcvers <- listVersions av (Just GHC) criteria
|
||||
cabalvers <- listVersions av (Just Cabal) criteria
|
||||
ghcupvers <- listVersions av (Just GHCup) criteria
|
||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||
|
||||
where
|
||||
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
|
||||
toListResult t (v, tags) = case t of
|
||||
GHC -> do
|
||||
lSet <- fmap (maybe False (== v)) $ ghcSet
|
||||
lInstalled <- ghcInstalled v
|
||||
fromSrc <- ghcSrcInstalled v
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
||||
Cabal -> do
|
||||
lSet <- fmap (== v) $ cabalSet
|
||||
lInstalled <- cabalInstalled v
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
GHCup -> do
|
||||
let lSet = prettyPVP ghcUpVer == prettyVer v
|
||||
let lInstalled = True
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
|
||||
|
||||
filter' :: [ListResult] -> [ListResult]
|
||||
filter' lr = case criteria of
|
||||
Nothing -> lr
|
||||
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
|
||||
Just ListSet -> filter (\ListResult {..} -> lSet) lr
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ GHC rm ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | This function may throw and crash in various ways.
|
||||
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmGHCVer ver = do
|
||||
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
|
||||
dir <- liftIO $ ghcupGHCDir ver
|
||||
let d' = toFilePath dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
|
||||
|
||||
if exists
|
||||
then do
|
||||
-- this isn't atomic, order matters
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
||||
lift $ rmMinorSymlinks ver
|
||||
|
||||
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
|
||||
-- first remove
|
||||
lift $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
(mj, mi) <- getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
||||
|
||||
when isSetGHC $ do
|
||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
||||
liftE $ rmPlain ver
|
||||
|
||||
liftIO
|
||||
$ ghcupBaseDir
|
||||
>>= hideError doesNotExistErrorType
|
||||
. deleteFile
|
||||
. (</> ([rel|share|] :: Path Rel))
|
||||
else throwE (NotInstalled GHC ver)
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Debug info ]--
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diURLSource <- lift $ getUrlSource
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Compile ]--
|
||||
---------------
|
||||
|
||||
|
||||
compileGHC :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bver jobs mbuildConfig = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC tver)
|
||||
(throwE $ AlreadyInstalled GHC tver)
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed workdir es)
|
||||
)
|
||||
$ compile bghc ghcdir workdir
|
||||
markSrcBuilt ghcdir workdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
pure ()
|
||||
|
||||
where
|
||||
defaultConf = [s|
|
||||
V=0
|
||||
BUILD_MAN = NO
|
||||
BUILD_SPHINX_HTML = NO
|
||||
BUILD_SPHINX_PDF = NO
|
||||
HADDOCK_DOCS = YES
|
||||
GhcWithLlvmCodeGen = YES|]
|
||||
|
||||
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
|
||||
=> Path Rel
|
||||
-> Path Abs
|
||||
-> Path Abs
|
||||
-> Excepts
|
||||
'[NoDownload , FileDoesNotExistError , ProcessError]
|
||||
m
|
||||
()
|
||||
compile bghc ghcdir workdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
if
|
||||
| tver >= [vver|8.8.0|] -> do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
|
||||
newEnv <- addToCurrentEnv [([s|GHC|], toFilePath bghcPath)]
|
||||
lEM $ liftIO $ execLogged [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath ghcdir]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
| otherwise -> do
|
||||
lEM $ liftIO $ execLogged
|
||||
[s|./configure|]
|
||||
False
|
||||
[ [s|--prefix=|] <> toFilePath ghcdir
|
||||
, [s|--with-ghc=|] <> toFilePath bghc
|
||||
]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
|
||||
Nothing ->
|
||||
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
||||
|
||||
lift
|
||||
$ $(logInfo)
|
||||
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
lift $ $(logInfo) [i|Installing...|]
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
markSrcBuilt ghcdir workdir = do
|
||||
let dest = (ghcdir </> ghcUpSrcBuiltFile)
|
||||
liftIO $ copyFile (build_mk workdir) dest Overwrite
|
||||
|
||||
build_mk workdir = workdir </> ([rel|mk/build.mk|] :: Path Rel)
|
||||
|
||||
|
||||
compileCabal :: ( MonadReader Settings m
|
||||
, MonadResource m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ GHC version to build with
|
||||
-> Maybe Int
|
||||
-> Excepts
|
||||
'[ BuildFailed
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileCabal dls tver bver jobs = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
|
||||
reThrowAll (BuildFailed workdir) $ compile workdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
compile :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> Excepts '[ProcessError] m ()
|
||||
compile workdir = do
|
||||
lift
|
||||
$ $(logInfo)
|
||||
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
|
||||
|
||||
let v' = verToBS bver
|
||||
cabal_bin <- liftIO $ ghcupBinDir
|
||||
newEnv <- lift $ addToCurrentEnv
|
||||
[ ([s|GHC|] , [s|ghc-|] <> v')
|
||||
, ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
|
||||
, ([s|GHC_VER|], v')
|
||||
, ([s|PREFIX|] , toFilePath cabal_bin)
|
||||
]
|
||||
|
||||
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
|
||||
False
|
||||
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
|
||||
([rel|cabal-bootstrap.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Upgrade GHCup ]--
|
||||
---------------------
|
||||
|
||||
|
||||
upgradeGHCup :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||
-> Excepts
|
||||
'[ CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
Version
|
||||
upgradeGHCup dls mtarget = do
|
||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
||||
let latestVer = head $ getTagged dls GHCup Latest
|
||||
dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = [rel|ghcup|] :: Path Rel
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
case mtarget of
|
||||
Nothing -> do
|
||||
dest <- liftIO $ ghcupBinDir
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
(dest </> fn)
|
||||
Overwrite
|
||||
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
|
||||
pure latestVer
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
|
||||
-- both installing from source and bindist.
|
||||
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
postGHCInstall ver = do
|
||||
liftE $ setGHC ver SetGHC_XYZ
|
||||
|
||||
-- Create ghc-x.y symlinks. This may not be the current
|
||||
-- version, create it regardless.
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
615
lib/GHCup/Download.hs
Normal file
615
lib/GHCup/Download.hs
Normal file
@@ -0,0 +1,615 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
module GHCup.Download where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text.Read
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
import Data.Time.Format
|
||||
import Data.Versions
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import OpenSSL.Digest
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import System.ProgressBar
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.Binary.Builder as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.IO.Streams as Streams
|
||||
import qualified System.Posix.Files.ByteString as PF
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
|
||||
|
||||
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ High-level ]--
|
||||
------------------
|
||||
|
||||
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
|
||||
getDownloads = do
|
||||
urlSource <- lift getUrlSource
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
where
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
--
|
||||
-- If not, then send a HEAD request and check for modification time.
|
||||
-- Only download the file if the modification time is newer
|
||||
-- than the local file.
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
dl :: forall m1
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
dl uri' = do
|
||||
let path = view pathL' uri'
|
||||
json_file <- (liftIO $ ghcupCacheDir)
|
||||
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <-
|
||||
PF.accessTimeHiRes
|
||||
<$> (liftIO $ PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO $ getPOSIXTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (currentTime - accessTime) > 300
|
||||
then do -- no access in last 5 minutes, re-check upstream mod time
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
else liftIO $ readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftIO $ deleteFile json_file
|
||||
liftE $ downloadBS uri'
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ readFile json_file
|
||||
else do
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftE $ downloadBS uri'
|
||||
|
||||
where
|
||||
getModTime = do
|
||||
headers <-
|
||||
handleIO (\_ -> pure mempty)
|
||||
$ liftE
|
||||
$ ( catchAllE
|
||||
(\_ ->
|
||||
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
|
||||
)
|
||||
$ getHead uri'
|
||||
)
|
||||
pure $ parseModifiedHeader headers
|
||||
|
||||
|
||||
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
|
||||
parseModifiedHeader headers =
|
||||
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
|
||||
True
|
||||
defaultTimeLocale
|
||||
"%a, %d %b %Y %H:%M:%S %Z"
|
||||
(T.unpack . E.decodeUtf8 $ h)
|
||||
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
writeFileL path (Just newFilePerms) content
|
||||
setModificationTimeHiRes path mod_time
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Tool
|
||||
-> Version
|
||||
-> Maybe PlatformRequest
|
||||
-> Excepts
|
||||
'[ DistroNotFound
|
||||
, NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo bDls t v mpfReq = do
|
||||
(PlatformRequest arch' plat ver) <- case mpfReq of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
ar <- lE getArchitecture
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
lE $ getDownloadInfo' t v arch' plat ver bDls
|
||||
|
||||
|
||||
getDownloadInfo' :: Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> Architecture
|
||||
-- ^ user arch
|
||||
-> Platform
|
||||
-- ^ user platform
|
||||
-> Maybe Versioning
|
||||
-- ^ optional version of the platform
|
||||
-> GHCupDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo' t v a p mv dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
-- and saves the result in continuous memory into a file.
|
||||
-- If the filename is not provided, then we:
|
||||
-- 1. try to guess the filename from the url path
|
||||
-- 2. otherwise create a random file
|
||||
--
|
||||
-- The file must not exist.
|
||||
download :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
download dli dest mfn
|
||||
| scheme == [s|https|] = dl
|
||||
| scheme == [s|http|] = dl
|
||||
| scheme == [s|file|] = cp
|
||||
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
||||
|
||||
where
|
||||
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
|
||||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
destFile <- getDestFile
|
||||
fromFile <- parseAbs path
|
||||
liftIO $ copyFile fromFile destFile Strict
|
||||
pure destFile
|
||||
dl = do
|
||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
|
||||
(https, host, fullPath, port) <- reThrowAll DownloadFailed
|
||||
$ uriToQuadruple (view dlUri dli)
|
||||
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
destFile <- getDestFile
|
||||
|
||||
-- download
|
||||
fd <- liftIO $ createRegularFileFd newFilePerms destFile
|
||||
let stepper = fdWrite fd
|
||||
flip finally (liftIO $ closeFd fd)
|
||||
$ reThrowAll DownloadFailed
|
||||
$ downloadInternal True https host fullPath port stepper
|
||||
|
||||
liftE $ checkDigest dli destFile
|
||||
pure destFile
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: MonadThrow m => m (Path Abs)
|
||||
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
downloadCached :: ( MonadMask m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cachedir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure $ cachfile
|
||||
| otherwise -> liftE $ download dli cachedir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Low-level ]--
|
||||
------------------
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path)
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ downloadBS' https host' fullPath' port'
|
||||
|
||||
|
||||
-- | Load the result of this download into memory at once.
|
||||
downloadBS' :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||
-> ByteString -- ^ path (e.g. "/my/file") including query
|
||||
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(L.ByteString)
|
||||
downloadBS' https host path port = do
|
||||
bref <- liftIO $ newIORef (mempty :: Builder)
|
||||
let stepper bs = modifyIORef bref (<> byteString bs)
|
||||
downloadInternal False https host path port stepper
|
||||
liftIO (readIORef bref <&> toLazyByteString)
|
||||
|
||||
|
||||
downloadInternal :: MonadIO m
|
||||
=> Bool -- ^ whether to show a progress bar
|
||||
-> Bool -- ^ https?
|
||||
-> ByteString -- ^ host
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> (ByteString -> IO a) -- ^ the consuming step function
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
()
|
||||
downloadInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs progressBar https host path port consumer = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Just r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Nothing -> pure ()
|
||||
where
|
||||
action c = do
|
||||
let q = buildRequest1 $ http GET path
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
receiveResponse
|
||||
c
|
||||
(\r i' -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
|
||||
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
|
||||
Just r' -> pure $ Just $ r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
|
||||
followRedirectURL bs = case parseURI strictURIParserOptions bs of
|
||||
Right uri' -> do
|
||||
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
go (redirs - 1) progressBar https' host' fullPath' port' consumer
|
||||
Left e -> throwE e
|
||||
|
||||
downloadStream r i' = do
|
||||
let size = case getHeader r [s|Content-Length|] of
|
||||
Just x' -> case decimal $ E.decodeUtf8 x' of
|
||||
Left _ -> 0
|
||||
Right (r', _) -> r'
|
||||
Nothing -> 0
|
||||
|
||||
mpb <- if progressBar
|
||||
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
|
||||
else pure Nothing
|
||||
|
||||
outStream <- liftIO $ Streams.makeOutputStream
|
||||
(\case
|
||||
Just bs -> do
|
||||
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
|
||||
void $ consumer bs
|
||||
Nothing -> pure ()
|
||||
)
|
||||
liftIO $ Streams.connect i' outStream
|
||||
|
||||
|
||||
|
||||
getHead :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
getHead uri' | scheme == [s|https|] = head' True
|
||||
| scheme == [s|http|] = head' False
|
||||
| otherwise = throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
head' https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ headInternal https host' fullPath' port'
|
||||
|
||||
|
||||
|
||||
headInternal :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, TooManyRedirs
|
||||
, NoLocationHeader
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
headInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs https host path port = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Left r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Right hs -> pure hs
|
||||
where
|
||||
|
||||
action c = do
|
||||
let q = buildRequest1 $ http HEAD path
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
unsafeReceiveResponse
|
||||
c
|
||||
(\r _ -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> do
|
||||
let headers = getHeaderMap r
|
||||
pure $ Right $ headers
|
||||
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
|
||||
Just r' -> pure $ Left $ r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
|
||||
followRedirectURL bs = case parseURI strictURIParserOptions bs of
|
||||
Right uri' -> do
|
||||
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
go (redirs - 1) https' host' fullPath' port'
|
||||
Left e -> throwE e
|
||||
|
||||
|
||||
withConnection' :: Bool
|
||||
-> ByteString
|
||||
-> Maybe Int
|
||||
-> (Connection -> IO a)
|
||||
-> IO a
|
||||
withConnection' https host port action = bracket acquire closeConnection action
|
||||
|
||||
where
|
||||
acquire = case https of
|
||||
True -> do
|
||||
ctx <- baselineContextSSL
|
||||
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
||||
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
|
||||
|
||||
|
||||
-- | Extracts from a URI type: (https?, host, path+query, port)
|
||||
uriToQuadruple :: Monad m
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[UnsupportedScheme]
|
||||
m
|
||||
(Bool, ByteString, ByteString, Maybe Int)
|
||||
uriToQuadruple URI {..} = do
|
||||
let scheme = view schemeBSL' uriScheme
|
||||
|
||||
host <-
|
||||
preview (_Just % authorityHostL' % hostBSL') uriAuthority
|
||||
?? UnsupportedScheme
|
||||
|
||||
https <- if
|
||||
| scheme == [s|https|] -> pure True
|
||||
| scheme == [s|http|] -> pure False
|
||||
| otherwise -> throwE UnsupportedScheme
|
||||
|
||||
let
|
||||
queryBS =
|
||||
BS.intercalate [s|&|]
|
||||
. fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
|
||||
$ (queryPairs uriQuery)
|
||||
port =
|
||||
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
|
||||
fullpath =
|
||||
if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
|
||||
pure (https, host, fullpath, port)
|
||||
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
|
||||
|
||||
|
||||
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
|
||||
=> DownloadInfo
|
||||
-> Path Abs
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest dli file = do
|
||||
verify <- lift ask <&> (not . noVerify)
|
||||
when verify $ do
|
||||
let p' = toFilePath file
|
||||
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
||||
c <- liftIO $ readFile file
|
||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
|
||||
eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
124
lib/GHCup/Errors.hs
Normal file
124
lib/GHCup/Errors.hs
Normal file
@@ -0,0 +1,124 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant
|
||||
import HPath
|
||||
|
||||
|
||||
|
||||
------------------------
|
||||
--[ Low-level errors ]--
|
||||
------------------------
|
||||
|
||||
|
||||
|
||||
-- | A compatible platform could not be found.
|
||||
data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
|
||||
deriving Show
|
||||
|
||||
-- | Unable to find a download for the requested versio/distro.
|
||||
data NoDownload = NoDownload
|
||||
deriving Show
|
||||
|
||||
-- | The Architecture is unknown and unsupported.
|
||||
data NoCompatibleArch = NoCompatibleArch String
|
||||
deriving Show
|
||||
|
||||
-- | Unable to figure out the distribution of the host.
|
||||
data DistroNotFound = DistroNotFound
|
||||
deriving Show
|
||||
|
||||
-- | The archive format is unknown. We don't know how to extract it.
|
||||
data UnknownArchive = UnknownArchive ByteString
|
||||
deriving Show
|
||||
|
||||
-- | The scheme is not supported (such as ftp).
|
||||
data UnsupportedScheme = UnsupportedScheme
|
||||
deriving Show
|
||||
|
||||
-- | Unable to copy a file.
|
||||
data CopyError = CopyError String
|
||||
deriving Show
|
||||
|
||||
-- | Unable to find a tag of a tool.
|
||||
data TagNotFound = TagNotFound Tag Tool
|
||||
deriving Show
|
||||
|
||||
-- | The tool (such as GHC) is already installed with that version.
|
||||
data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||
deriving Show
|
||||
|
||||
-- | The tool is not installed. Some operations rely on a tool
|
||||
-- to be installed (such as setting the current GHC version).
|
||||
data NotInstalled = NotInstalled Tool Version
|
||||
deriving Show
|
||||
|
||||
-- | JSON decoding failed.
|
||||
data JSONError = JSONDecodeError String
|
||||
deriving Show
|
||||
|
||||
-- | A file that is supposed to exist does not exist
|
||||
-- (e.g. when we use file scheme to "download" something).
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
-- | File digest verification failed.
|
||||
data DigestError = DigestError Text Text
|
||||
deriving Show
|
||||
|
||||
-- | Unexpected HTTP status.
|
||||
data HTTPStatusError = HTTPStatusError Int
|
||||
deriving Show
|
||||
|
||||
-- | The 'Location' header was expected during a 3xx redirect, but not found.
|
||||
data NoLocationHeader = NoLocationHeader
|
||||
deriving Show
|
||||
|
||||
-- | Too many redirects.
|
||||
data TooManyRedirs = TooManyRedirs
|
||||
deriving Show
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ High-level errors ]--
|
||||
-------------------------
|
||||
|
||||
-- | A download failed. The underlying error is encapsulated.
|
||||
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
|
||||
|
||||
deriving instance Show DownloadFailed
|
||||
|
||||
|
||||
-- | A build failed.
|
||||
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
|
||||
|
||||
deriving instance Show BuildFailed
|
||||
|
||||
|
||||
-- | Setting the current GHC version failed.
|
||||
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
|
||||
|
||||
deriving instance Show GHCupSetError
|
||||
|
||||
|
||||
---------------------------------------------
|
||||
--[ True Exceptions (e.g. for MonadThrow) ]--
|
||||
---------------------------------------------
|
||||
|
||||
|
||||
-- | Parsing failed.
|
||||
data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ParseError
|
||||
166
lib/GHCup/Platform.hs
Normal file
166
lib/GHCup/Platform.hs
Normal file
@@ -0,0 +1,166 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Platform where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Bash
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
--------------------------
|
||||
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
"i386" -> Right A_32
|
||||
what -> Left (NoCompatibleArch what)
|
||||
|
||||
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
pfr <- case os of
|
||||
"linux" -> do
|
||||
(distro, ver) <- liftE getLinuxDistro
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
-- TODO: these are not verified
|
||||
"darwin" ->
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
|
||||
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
||||
getLinuxDistro = do
|
||||
-- TODO: don't do alternative on IO, because it hides bugs
|
||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||
[ try_os_release
|
||||
, try_lsb_release_cmd
|
||||
, try_lsb_release
|
||||
, try_redhat_release
|
||||
, try_debian_version
|
||||
]
|
||||
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
||||
distro = if
|
||||
| hasWord name ["debian"] -> Debian
|
||||
| hasWord name ["ubuntu"] -> Ubuntu
|
||||
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
||||
| hasWord name ["fedora"] -> Fedora
|
||||
| hasWord name ["centos"] -> CentOS
|
||||
| hasWord name ["Red Hat"] -> RedHat
|
||||
| hasWord name ["alpine"] -> Alpine
|
||||
| hasWord name ["exherbo"] -> Exherbo
|
||||
| hasWord name ["gentoo"] -> Gentoo
|
||||
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
|
||||
| otherwise -> UnknownLinux
|
||||
pure (distro, parsedVer)
|
||||
where
|
||||
hasWord t matches = foldr
|
||||
(\x y ->
|
||||
( isJust
|
||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
|
||||
$ t
|
||||
)
|
||||
|| y
|
||||
)
|
||||
False
|
||||
(T.pack <$> matches)
|
||||
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
lsb_release :: Path Abs
|
||||
lsb_release = [abs|/etc/lsb-release|]
|
||||
lsb_release_cmd :: Path Rel
|
||||
lsb_release_cmd = [rel|lsb-release|]
|
||||
redhat_release :: Path Abs
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||
try_lsb_release_cmd = do
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
try_lsb_release = do
|
||||
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
||||
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- fmap lBS2sT $ readFile redhat_release
|
||||
let nameRe n =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
|
||||
$ t
|
||||
verRe =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
|
||||
$ t
|
||||
(Just name) <- pure
|
||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||
pure (name, verRe)
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just $ lBS2sT ver)
|
||||
144
lib/GHCup/Types.hs
Normal file
144
lib/GHCup/Types.hs
Normal file
@@ -0,0 +1,144 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Download Tree ]--
|
||||
---------------------
|
||||
|
||||
|
||||
-- | Description of all binary and source downloads. This is a tree
|
||||
-- of nested maps.
|
||||
type GHCupDownloads = Map Tool ToolVersionSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
|
||||
|
||||
-- | An installable tool.
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | All necessary information of a tool version, including
|
||||
-- source download and per-architecture downloads.
|
||||
data VersionInfo = VersionInfo
|
||||
{ _viTags :: [Tag] -- ^ version specific tag
|
||||
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
|
||||
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
| Mint
|
||||
| Fedora
|
||||
| CentOS
|
||||
| RedHat
|
||||
| Alpine
|
||||
| AmazonLinux
|
||||
-- rolling
|
||||
| Gentoo
|
||||
| Exherbo
|
||||
-- not known
|
||||
| UnknownLinux
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | An encapsulation of a download. This can be used
|
||||
-- to download, extract and install a tool.
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupDownloads
|
||||
deriving Show
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noVerify :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diURLSource :: URLSource
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHC_XY -- ^ ghc-x.y
|
||||
| SetGHC_XYZ -- ^ ghc-x.y.z
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data PlatformRequest = PlatformRequest
|
||||
{ _rArch :: Architecture
|
||||
, _rPlatform :: Platform
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
149
lib/GHCup/Types/JSON.hs
Normal file
149
lib/GHCup/Types/JSON.hs
Normal file
@@ -0,0 +1,149 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
import Data.Text.Encoding ( decodeUtf8 )
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
|
||||
|
||||
instance ToJSON URI where
|
||||
toJSON = toJSON . decodeUtf8 . serializeURIRef'
|
||||
|
||||
instance FromJSON URI where
|
||||
parseJSON = withText "URL" $ \t ->
|
||||
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
||||
Right x -> pure x
|
||||
Left e -> fail . show $ e
|
||||
|
||||
instance ToJSON Versioning where
|
||||
toJSON = toJSON . prettyV
|
||||
|
||||
instance FromJSON Versioning where
|
||||
parseJSON = withText "Versioning" $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Versioning where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyV x
|
||||
|
||||
instance FromJSONKey Versioning where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Platform where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Darwin -> T.pack "Darwin"
|
||||
FreeBSD -> T.pack "FreeBSD"
|
||||
Linux d -> T.pack ("Linux_" <> show d)
|
||||
|
||||
instance FromJSONKey Platform where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> if
|
||||
| T.pack "Darwin" == t -> pure Darwin
|
||||
| T.pack "FreeBSD" == t -> pure FreeBSD
|
||||
| T.pack "Linux_" `T.isPrefixOf` t -> case
|
||||
T.stripPrefix (T.pack "Linux_") t
|
||||
of
|
||||
Just dstr ->
|
||||
case
|
||||
(decodeStrict (E.encodeUtf8 (T.pack "\"" <> dstr <> T.pack "\"")) :: Maybe
|
||||
LinuxDistro
|
||||
)
|
||||
of
|
||||
Just d -> pure $ Linux d
|
||||
Nothing ->
|
||||
fail
|
||||
$ "Unexpected failure in decoding LinuxDistro: "
|
||||
<> show dstr
|
||||
Nothing -> fail "Unexpected failure in Platform stripPrefix"
|
||||
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
|
||||
|
||||
instance ToJSONKey Architecture where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance FromJSONKey Architecture where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSON Version where
|
||||
toJSON = toJSON . prettyVer
|
||||
|
||||
instance FromJSON Version where
|
||||
parseJSON = withText "Version" $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Version where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyVer x
|
||||
|
||||
instance FromJSONKey Version where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Tool where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance FromJSONKey Tool where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSON (Path Rel) where
|
||||
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
|
||||
True -> toJSON . E.decodeUtf8 $ fp
|
||||
False -> String [s|/not/a/valid/path|]
|
||||
where fp = toFilePath p
|
||||
|
||||
instance FromJSON (Path Rel) where
|
||||
parseJSON = withText "HPath Rel" $ \t -> do
|
||||
let d = encodeUtf8 t
|
||||
case parseRel d of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
|
||||
48
lib/GHCup/Types/Optics.hs
Normal file
48
lib/GHCup/Types/Optics.hs
Normal file
@@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Types.Optics where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Data.ByteString ( ByteString )
|
||||
import Optics
|
||||
import URI.ByteString
|
||||
|
||||
makePrisms ''Tool
|
||||
makePrisms ''Architecture
|
||||
makePrisms ''LinuxDistro
|
||||
makePrisms ''Platform
|
||||
makePrisms ''Tag
|
||||
|
||||
makeLenses ''PlatformResult
|
||||
makeLenses ''DownloadInfo
|
||||
makeLenses ''Tag
|
||||
makeLenses ''VersionInfo
|
||||
|
||||
|
||||
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
|
||||
uriSchemeL' = lensVL uriSchemeL
|
||||
|
||||
schemeBSL' :: Lens' Scheme ByteString
|
||||
schemeBSL' = lensVL schemeBSL
|
||||
|
||||
authorityL' :: Lens' (URIRef a) (Maybe Authority)
|
||||
authorityL' = lensVL authorityL
|
||||
|
||||
authorityHostL' :: Lens' Authority Host
|
||||
authorityHostL' = lensVL authorityHostL
|
||||
|
||||
authorityPortL' :: Lens' Authority (Maybe Port)
|
||||
authorityPortL' = lensVL authorityPortL
|
||||
|
||||
portNumberL' :: Lens' Port Int
|
||||
portNumberL' = lensVL portNumberL
|
||||
|
||||
hostBSL' :: Lens' Host ByteString
|
||||
hostBSL' = lensVL hostBSL
|
||||
|
||||
pathL' :: Lens' (URIRef a) ByteString
|
||||
pathL' = lensVL pathL
|
||||
|
||||
queryL' :: Lens' (URIRef a) Query
|
||||
queryL' = lensVL queryL
|
||||
330
lib/GHCup/Utils.hs
Normal file
330
lib/GHCup/Utils.hs
Normal file
@@ -0,0 +1,330 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Utils
|
||||
( module GHCup.Utils.Dirs
|
||||
, module GHCup.Utils
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import Safe
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------------
|
||||
--[ Symlink handling ]--
|
||||
------------------------
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
|
||||
|
||||
-- | Extract the version part of the result of `ghcLinkDestination`.
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
||||
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
||||
where
|
||||
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
-- e.g. ghc-8.6.5
|
||||
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
|
||||
rmMinorSymlinks ver = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles =
|
||||
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
-- E.g. ghc, if this version is the set one.
|
||||
-- This reads `ghcupGHCDir`.
|
||||
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain ver = do
|
||||
files <- liftE $ ghcToolFiles ver
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = (bindir </> [rel|haddock-ghc|])
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
-- e.g. ghc-8.6
|
||||
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
|
||||
rmMajorSymlinks ver = do
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------------
|
||||
--[ Set/Installed introspection ]--
|
||||
-----------------------------------
|
||||
|
||||
|
||||
toolAlreadyInstalled :: Tool -> Version -> IO Bool
|
||||
toolAlreadyInstalled tool ver = case tool of
|
||||
GHC -> ghcInstalled ver
|
||||
Cabal -> cabalInstalled ver
|
||||
GHCup -> pure True
|
||||
|
||||
|
||||
ghcInstalled :: Version -> IO Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSrcInstalled :: Version -> IO Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
cabalInstalled ver = do
|
||||
reportedVer <- cabalSet
|
||||
pure (reportedVer == ver)
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
|
||||
-----------------------------------------
|
||||
--[ Major version introspection (X.Y) ]--
|
||||
-----------------------------------------
|
||||
|
||||
|
||||
-- | We assume GHC is in semver format. I hope it is.
|
||||
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
|
||||
getGHCMajor ver = do
|
||||
SemVer {..} <- throwEither (semver $ prettyVer ver)
|
||||
pure (fromIntegral _svMajor, fromIntegral _svMinor)
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
mapM (throwEither . version)
|
||||
. fmap prettySemVer
|
||||
. lastMay
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
)
|
||||
$ semvers
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Unpacking ]--
|
||||
-----------------
|
||||
|
||||
|
||||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
-> Excepts '[UnknownArchive] m ()
|
||||
unpackToDir dest av = do
|
||||
let fp = E.decodeUtf8 (toFilePath av)
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
|
||||
|
||||
------------
|
||||
--[ Tags ]--
|
||||
------------
|
||||
|
||||
|
||||
-- | Get the tool versions that have this tag.
|
||||
getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
|
||||
getTagged av tool tag = toListOf
|
||||
( ix tool
|
||||
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
% to Map.keys
|
||||
% folded
|
||||
)
|
||||
av
|
||||
|
||||
getLatest :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getLatest av tool = headOf folded $ getTagged av tool Latest
|
||||
|
||||
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ Settings Getter ]--
|
||||
-----------------------
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
|
||||
-- while ignoring *-<ver> symlinks.
|
||||
--
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
|
||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
|
||||
-- fail if ghc is not installed
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
-- alpha/rc releases, but x.y.a.somedate.
|
||||
(Just symver) <-
|
||||
(B.stripPrefix [s|ghc-|] . takeFileName)
|
||||
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
|
||||
when (B.null symver)
|
||||
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
||||
|
||||
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
|
||||
|
||||
|
||||
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
69
lib/GHCup/Utils/Bash.hs
Normal file
69
lib/GHCup/Utils/Bash.hs
Normal file
@@ -0,0 +1,69 @@
|
||||
module GHCup.Utils.Bash
|
||||
( findAssignment
|
||||
, equalsAssignmentWith
|
||||
, getRValue
|
||||
, getAssignmentValueFor
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.ByteString.UTF8 ( toString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Language.Bash.Parse
|
||||
import Language.Bash.Syntax
|
||||
import Language.Bash.Word
|
||||
import Prelude hiding ( readFile )
|
||||
|
||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||
|
||||
|
||||
extractAssignments :: List -> [Assign]
|
||||
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||
where
|
||||
getCommands :: [Statement] -> [Command]
|
||||
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||
where
|
||||
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||
findPipes _ = Nothing
|
||||
|
||||
getAssign :: Command -> [Assign]
|
||||
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||
getAssign _ = []
|
||||
|
||||
|
||||
-- | Find an assignment matching the predicate in the given file.
|
||||
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||
findAssignment p predicate = do
|
||||
fileContents <- readFile p
|
||||
-- TODO: this should accept bytestring:
|
||||
-- https://github.com/knrafto/language-bash/issues/37
|
||||
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||
Left e -> fail $ show e
|
||||
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||
|
||||
|
||||
-- | Check that the assignment is of the form Foo= ignoring the
|
||||
-- right hand-side.
|
||||
equalsAssignmentWith :: String -> Assign -> Bool
|
||||
equalsAssignmentWith n ass = case ass of
|
||||
(Assign (Parameter name' Nothing) Equals _) -> n == name'
|
||||
_ -> False
|
||||
|
||||
|
||||
-- | This pretty-prints the right hand of an Equals assignment, removing
|
||||
-- quotations. No evaluation is performed.
|
||||
getRValue :: Assign -> Maybe String
|
||||
getRValue ass = case ass of
|
||||
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- | Given a bash assignment such as Foo="Bar" in the given file,
|
||||
-- will return "Bar" (without quotations).
|
||||
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
|
||||
getAssignmentValueFor p n = do
|
||||
mass <- findAssignment p (equalsAssignmentWith n)
|
||||
pure (mass >>= getRValue)
|
||||
91
lib/GHCup/Utils/Dirs.hs
Normal file
91
lib/GHCup/Utils/Dirs.hs
Normal file
@@ -0,0 +1,91 @@
|
||||
{-# 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
|
||||
246
lib/GHCup/Utils/File.hs
Normal file
246
lib/GHCup/Utils/File.hs
Normal file
@@ -0,0 +1,246 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Data.ByteString
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import System.IO
|
||||
import System.Posix.Directory.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.Types
|
||||
|
||||
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
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.Lazy as L
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
| PTerminated ByteString [ByteString]
|
||||
| PStopped ByteString [ByteString]
|
||||
| NoSuchPid ByteString [ByteString]
|
||||
deriving Show
|
||||
|
||||
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: ByteString
|
||||
, _stdErr :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
|
||||
readFd :: Fd -> IO L.ByteString
|
||||
readFd fd = do
|
||||
handle' <- fdToHandle fd
|
||||
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
|
||||
|
||||
|
||||
-- | Read the lines of a file into a stream. The stream holds
|
||||
-- a file handle as a resource and will close it once the stream
|
||||
-- terminates (either through exception or because it's drained).
|
||||
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||
readFileLines p = do
|
||||
stream <- readFileStream p
|
||||
pure
|
||||
. (fmap fromArray)
|
||||
. AS.splitOn (fromIntegral $ ord '\n')
|
||||
. (fmap toArray)
|
||||
$ stream
|
||||
|
||||
|
||||
-- | Find the given executable by searching all *absolute* PATH components.
|
||||
-- Relative paths in PATH are ignored.
|
||||
--
|
||||
-- This shouldn't throw IO exceptions, unless getting the environment variable
|
||||
-- PATH does.
|
||||
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
|
||||
findExecutable ex = do
|
||||
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||
-- We don't want exceptions to mess up our result. If we can't
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
|
||||
sPaths
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
execLogged :: 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 _)) -> 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.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action =
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
void $ action
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> Path b -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe spath args chdir env = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: ByteString
|
||||
-> [ByteString]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
-- | Convert the String to a ByteString with the current
|
||||
-- system encoding.
|
||||
unsafePathToString :: Path b -> IO FilePath
|
||||
unsafePathToString p = do
|
||||
enc <- getLocaleEncoding
|
||||
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM PermissionDenied (go xs)
|
||||
$ hideErrorDefM NoSuchThing (go xs)
|
||||
$ do
|
||||
dirStream <- openDirStream (toFilePath x)
|
||||
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
|
||||
>>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == toFilePath needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
60
lib/GHCup/Utils/Logger.hs
Normal file
60
lib/GHCup/Utils/Logger.hs
Normal file
@@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Utils
|
||||
|
||||
import Control.Monad
|
||||
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
|
||||
|
||||
|
||||
data LoggerConfig = LoggerConfig
|
||||
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
|
||||
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
|
||||
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
|
||||
}
|
||||
|
||||
|
||||
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
|
||||
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
where
|
||||
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
mylogger _ _ level str' = do
|
||||
-- color output
|
||||
let l = case level of
|
||||
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
|
||||
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
|
||||
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
|
||||
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
|
||||
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
|
||||
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
|
||||
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
|
||||
$ colorOutter out
|
||||
|
||||
-- raw output
|
||||
let lr = case level of
|
||||
LevelDebug -> toLogStr "Debug: "
|
||||
LevelInfo -> toLogStr "Info:"
|
||||
LevelWarn -> toLogStr "Warn:"
|
||||
LevelError -> toLogStr "Error:"
|
||||
LevelOther t -> toLogStr t <> toLogStr ":"
|
||||
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: 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
|
||||
243
lib/GHCup/Utils/Prelude.hs
Normal file
243
lib/GHCup/Utils/Prelude.hs
Normal file
@@ -0,0 +1,243 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.Utils.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Monoid ( (<>) )
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding 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
|
||||
|
||||
|
||||
|
||||
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
|
||||
|
||||
lBS2sT :: L.ByteString -> Text
|
||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||
|
||||
|
||||
|
||||
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 . bimap f id
|
||||
|
||||
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 . bimap f id
|
||||
|
||||
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
|
||||
|
||||
|
||||
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
|
||||
hideErrorDef err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
|
||||
|
||||
|
||||
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
|
||||
hideErrorDefM err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then def else 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 action =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
|
||||
|
||||
|
||||
hideExcept' :: forall e es es' m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
hideExcept' _ action =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
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'
|
||||
|
||||
|
||||
addToCurrentEnv :: MonadIO m
|
||||
=> [(ByteString, ByteString)]
|
||||
-> m [(ByteString, ByteString)]
|
||||
addToCurrentEnv adds = do
|
||||
cEnv <- liftIO $ getEnvironment
|
||||
pure (adds ++ cEnv)
|
||||
48
lib/GHCup/Utils/String/QQ.hs
Normal file
48
lib/GHCup/Utils/String/QQ.hs
Normal 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
89
lib/GHCup/Utils/Version/QQ.hs
Normal 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)
|
||||
11
lib/GHCup/Version.hs
Normal file
11
lib/GHCup/Version.hs
Normal file
@@ -0,0 +1,11 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
|
||||
module GHCup.Version where
|
||||
|
||||
import GHCup.Utils.Version.QQ
|
||||
|
||||
import Data.Versions
|
||||
|
||||
ghcUpVer :: PVP
|
||||
ghcUpVer = [pver|0.1.0|]
|
||||
Reference in New Issue
Block a user