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

More stuff

Browse Source
This commit is contained in:
Julian Ospald
2020-02-29 00:33:32 +01:00
parent 30ed7f0226
commit 6489e8430b
12 changed files with 1363 additions and 410 deletions
Download Patch File Download Diff File Expand all files Collapse all files

673
lib/GHCup.hs
View File

@@ -23,15 +23,21 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class ( lift )
import Control.Monad.IO.Class
import Control.Exception.Safe
import Data.Aeson
import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString )
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Foldable ( asum )
import Data.String.QQ
import Data.Text ( Text )
import Data.Versions
import Data.IORef
import GHCup.Bash
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import GHCup.Types.JSON
import GHCup.Types.Optics
import HPath
import HPath.IO
@@ -39,8 +45,10 @@ import Optics
import Prelude hiding ( abs
, readFile
)
import Data.List
import System.Info
import System.IO.Error
import Data.Foldable ( foldrM )
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU
@@ -90,14 +98,21 @@ import System.Posix.Directory.ByteString
( changeWorkingDirectory )
import URI.ByteString
import URI.ByteString.QQ
import Data.String.Interpolate
import Safe
data Settings = Settings
{ cache :: Bool
{ cache :: Bool
, urlSource :: URLSource
}
deriving Show
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
@@ -136,6 +151,17 @@ data AlreadyInstalled = AlreadyInstalled ToolRequest
data NotInstalled = NotInstalled ToolRequest
deriving Show
data NotSet = NotSet Tool
deriving Show
data JSONError = JSONDecodeError String
deriving Show
data ParseError = ParseError String
deriving Show
instance Exception ParseError
--------------------------------
@@ -143,76 +169,9 @@ data NotInstalled = NotInstalled ToolRequest
--------------------------------
-- TODO: version quasiquoter
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
[ ( [ver|8.6.5|]
, VersionInfo [Latest] $ Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Ubuntu
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Debian
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
, ( Just $ [vers|8|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
]
)
]
)
]
)
, ( Cabal
, Map.fromList
[ ( [ver|3.0.0.0|]
, VersionInfo [Recommended, Latest] $ Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
Nothing
)
]
)
]
)
]
)
]
)
]
ghcupURL :: URI
ghcupURL =
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
-- | Get the tool versions that have this tag.
@@ -232,26 +191,49 @@ getRecommended :: AvailableDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadReader Settings m
)
=> Excepts '[URLException , JSONError] m AvailableDownloads
getDownloads = lift getUrlSource >>= \case
GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource uri) -> do
bs <- liftE $ downloadBS uri
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
----------------------
--[ Download stuff ]--
----------------------
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> Excepts
'[ PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, URLException
, JSONError
]
m
DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource)
getDownloadInfo (ToolRequest t v) mpfReq = do
urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
-- lift $ monadLoggerLog undefined undefined undefined ""
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
@@ -260,11 +242,7 @@ getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
dls <- case urlSource of
-- TODO
GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
dls <- liftE $ getDownloads
lE $ getDownloadInfo' t v arch plat ver dls
@@ -294,41 +272,24 @@ getDownloadInfo' t v a p mv dls = maybe
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 :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename
-> IO (Path Abs)
download https host path port dest mfn = do
fromJust <$> downloadInternal https host path port (Right (dest, mfn))
-- | Same as 'download', except uses URL type. As such, this might
-- | Same as `download'`, except uses URL type. As such, this might
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
download' :: (MonadLogger m, MonadIO m)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[URLException] m (Path Abs)
download' dli dest mfn
download :: (MonadLogger m, MonadIO m)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[URLException] m (Path Abs)
download dli dest mfn
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
| otherwise = throwE UnsupportedURL
where
dl https = do
lift $ $(logInfo)
([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli)))
let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri}|]
host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL
@@ -336,65 +297,49 @@ download' dli dest mfn
let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
liftIO $ download https host path port dest mfn
-- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout.
downloadFd :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Fd -- ^ function creating an Fd to write the body into
-> IO ()
downloadFd https host path port fd =
void $ downloadInternal https host path port (Left fd)
liftIO $ download' https host path port dest mfn
downloadInternal :: Bool
-> ByteString
-> ByteString
-> Maybe Int
-> Either Fd (Path Abs, Maybe (Path Rel))
-> IO (Maybe (Path Abs))
downloadInternal https host path port dest = do
c <- case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
let q = buildRequest1 $ http GET ([s|/|] <> path)
sendRequest c q emptyBody
(fd, mfp) <- case dest of
Right (dest, mfn) -> getFile dest mfn <&> (<&> Just)
Left fd -> pure (fd, Nothing)
-- wrapper so we can close Fds we created
let receiveResponse' c b = case dest of
Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b
Left _ -> receiveResponse c b
receiveResponse'
c
(\p i -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ fdWrite fd bs
Nothing -> pure ()
)
Streams.connect i outStream
)
closeConnection c
pure mfp
downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString
downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True
| view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False
| otherwise = throwE UnsupportedURL
where
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri
?? UnsupportedURL
let path = view pathL' uri
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
uri
liftIO $ downloadBS' https host path port
-- | 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' :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename
-> IO (Path Abs)
download' https host path port dest mfn = do
(fd, fp) <- getFile
let stepper = fdWrite fd
flip finally (closeFd fd) $ downloadInternal https host path port stepper
pure fp
where
-- Manage to find a file we can write the body into.
getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs)
getFile dest mfn = do
getFile :: IO (Fd, Path Abs)
getFile = do
-- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of
@@ -409,6 +354,50 @@ downloadInternal https host path port dest = do
fmap (, fp) $ createRegularFileFd newFilePerms fp
-- | Load the result of this download into memory at once.
downloadBS' :: Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> IO (L.ByteString)
downloadBS' https host path port = do
bref <- newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
downloadInternal https host path port stepper
readIORef bref <&> toLazyByteString
downloadInternal :: Bool
-> ByteString
-> ByteString
-> Maybe Int
-> (ByteString -> IO a) -- ^ the consuming step function
-> IO ()
downloadInternal https host path port consumer = do
c <- case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
let q = buildRequest1 $ http GET path
sendRequest c q emptyBody
receiveResponse
c
(\p i -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ consumer bs
Nothing -> pure ()
)
Streams.connect i outStream
)
closeConnection c
--------------------------
--[ Platform detection ]--
@@ -440,7 +429,7 @@ getPlatform = do
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE NoCompatiblePlatform
lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr)
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where getFreeBSDVersion = pure Nothing
@@ -547,7 +536,8 @@ getLinuxDistro = do
-- TODO: custom logger intepreter and pretty printing
-- | Install a tool, such as GHC or cabal.
-- | Install a tool, such as GHC or cabal. This also sets
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
@@ -560,7 +550,6 @@ installTool :: ( MonadThrow m
)
=> ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> URLSource
-> Excepts
'[ AlreadyInstalled
, FileError
@@ -572,18 +561,20 @@ installTool :: ( MonadThrow m
, NoCompatibleArch
, DistroNotFound
, NotInstalled
, URLException
, JSONError
]
m
()
installTool treq mpfReq urlSource = do
lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
installTool treq mpfReq = do
lift $ $(logDebug) [i|Requested to install: #{treq}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource
dlinfo <- liftE $ getDownloadInfo treq mpfReq
dl <- case cache of
True -> do
cachedir <- liftIO $ ghcupCacheDir
@@ -592,10 +583,10 @@ installTool treq mpfReq urlSource = do
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> pure $ cachfile
| otherwise -> liftE $ download' dlinfo cachedir Nothing
| otherwise -> liftE $ download dlinfo cachedir Nothing
False -> do
tmp <- liftIO mkGhcupTmpDir
liftE $ download' dlinfo tmp Nothing
liftE $ download dlinfo tmp Nothing
-- unpack
unpacked <- liftE $ unpackToTmpDir dl
@@ -607,11 +598,15 @@ installTool treq mpfReq urlSource = do
-- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
-- TODO: test if tool is already installed
case treq of
(ToolRequest GHC ver) -> do
(ToolRequest GHC ver) -> do
liftE $ installGHC archiveSubdir ghcdir
liftE $ setGHC ver SetGHCOnly
liftE $ setGHC ver SetGHCMinor
-- 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 SetGHCMajor)
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure ()
@@ -629,7 +624,7 @@ installGHC :: (MonadLogger m, MonadIO m)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC path inst = do
lift $ $(logInfo) ([s|Installing GHC|])
lift $ $(logInfo) [s|Installing GHC|]
lEM $ liftIO $ exec [s|./configure|]
[[s|--prefix=|] <> toFilePath inst]
False
@@ -644,7 +639,7 @@ installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
-> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m ()
installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|])
lift $ $(logInfo) [s|Installing cabal|]
let cabalFile = [rel|cabal|] :: Path Rel
liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
@@ -653,12 +648,19 @@ installCabal path inst = do
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-<ver>
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
@@ -667,67 +669,204 @@ setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
-> SetGHC
-> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
let verBS = E.encodeUtf8 $ prettyVer ver -- as ByteString
ghcdir <- liftIO $ ghcupGHCDir ver
let verBS = verToBS ver
ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination
destdir <- liftIO $ ghcupBinDir
destdir <- liftIO $ ghcupBinDir
liftIO $ createDirIfMissing newDirPerms destdir
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ghcdir
verfiles <- ghcToolFiles ver
forM verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHCMajor -> do
major <- E.encodeUtf8 <$> getGHCMajor ver
major <-
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
<$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major)
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ createSymlink
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> targetFile)
([s|../ghc/|] <> verBS <> [s|/bin/|] <> toFilePath file)
liftIO $ createSymlink (destdir </> targetFile)
(ghcLinkDestination (toFilePath file) ver)
-- create symlink for share dir
liftIO $ symlinkShareDir ghcdir destdir verBS
liftIO $ symlinkShareDir ghcdir verBS
pure ()
where
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ghcdir = do
-- fail if ghc is not installed
exists <- liftIO $ doesDirectoryExist ghcdir
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
-- 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
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
symlinkShareDir :: Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir verBS = do
destdir <- ghcupBaseDir
case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> sharedir)
createSymlink
(destdir </> sharedir)
([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> pure ()
------------------
--[ List tools ]--
------------------
data ListCriteria = ListInstalled
| ListSet
deriving Show
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
, lTag :: [Tag]
, lInstalled :: Bool
, lSet :: Bool
}
deriving Show
availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
av
listVersions :: (MonadReader Settings m, MonadIO m)
=> Maybe Tool
-> Maybe ListCriteria
-> Excepts '[URLException , JSONError] m [ListResult]
listVersions lt criteria = do
dls <- liftE $ getDownloads
liftIO $ listVersions' dls lt criteria
listVersions' :: AvailableDownloads
-> 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
pure (ghcvers <> cabalvers)
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
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, .. }
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
------------------
--[ List tools ]--
------------------
-- | 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
let v' = prettyVer ver
exists <- liftIO $ doesDirectoryExist dir
toolsFiles <- liftE $ ghcToolFiles ver
if exists
then do
-- this isn't atomic
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
liftIO $ rmMinorSymlinks
lift $ $(logInfo) [i|Removing ghc-x.y symlinks|]
liftE fixMajorSymlinks
when isSetGHC $ liftE $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
rmPlain dir toolsFiles
liftIO
$ ghcupBaseDir
>>= hideError doesNotExistErrorType
. deleteFile
. (</> ([rel|share|] :: Path Rel))
else throwE (NotInstalled $ ToolRequest GHC ver)
where
-- e.g. ghc-8.6.5
rmMinorSymlinks :: IO ()
rmMinorSymlinks = do
bindir <- ghcupBinDir
files <- getDirsFiles' bindir
let myfiles = filter
(\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
files
forM_ myfiles $ \f -> deleteFile (bindir </> f)
-- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`.
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> [Path Rel] -- ^ tools files
-> Excepts '[NotInstalled] m ()
rmPlain ghcDir files = do
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
-- e.g. ghc-8.6
fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
=> Excepts '[NotInstalled] m ()
fixMajorSymlinks = do
(mj, mi) <- getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
bindir <- liftIO $ ghcupBinDir
-- first delete them
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)
-- then fix them (e.g. with an earlier version)
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
symlinkShareDir :: Path Abs -> Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir destdir verBS = case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> sharedir)
createSymlink
(destdir </> sharedir)
([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> pure ()
-----------------
@@ -746,14 +885,43 @@ ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (E.encodeUtf8 $ prettyVer ver)
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
-- | 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
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
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
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
@@ -765,17 +933,43 @@ cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
pure (reportedVer == (E.encodeUtf8 $ prettyVer ver))
pure (reportedVer == (verToBS 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
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m Text
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do
semv <- case semver $ prettyVer ver of
Right v -> pure v
Left e -> throwM e
pure $ T.pack (show (_svMajor semv)) <> T.pack "." <> T.pack
(show (_svMinor semv))
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
urlBaseName :: MonadThrow m
@@ -790,7 +984,8 @@ unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do
lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|]
fn <- toFilePath <$> basename av
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
@@ -810,3 +1005,29 @@ unpackToTmpDir av = do
(untar . BZip.decompress =<< readFile av)
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver
-- fail if ghc is not installed
exists <- liftIO $ doesDirectoryExist ghcdir
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
-- 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
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files

50
lib/GHCup/Logger.hs Normal file
View File

@@ -0,0 +1,50 @@
module GHCup.Logger where
import GHCup
import GHCup.Types
import GHCup.Types.Optics
import Control.Monad
import Control.Exception.Safe
import Control.Monad.Reader.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( ReaderT
, runReaderT
)
import Data.List
import Data.String.QQ
import Data.String.Interpolate
import Data.Versions
import Data.IORef
import Optics
import System.Exit
import System.Console.Pretty
import System.IO
import Control.Monad.Logger
import qualified Data.Map.Strict as M
import qualified Data.ByteString as B
myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
myLoggerT outter loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger loc source level str = do
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")
outter out
myLoggerTStdout :: LoggingT m a -> m a
myLoggerTStdout = myLoggerT (B.hPut stdout)
myLoggerTStderr :: LoggingT m a -> m a
myLoggerTStderr = myLoggerT (B.hPut stderr)

36
lib/GHCup/Prelude.hs
View File

@@ -17,13 +17,18 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe
import Data.Bifunctor
import Data.ByteString ( ByteString )
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) )
import Data.String
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import Data.Text ( Text )
import qualified Data.Text.Encoding as E
import qualified Data.Text as T
import Data.Versions
import qualified Data.ByteString.Lazy as L
@@ -94,7 +99,7 @@ lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8
handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
@@ -114,9 +119,23 @@ handleIO' err handler =
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
@@ -130,6 +149,12 @@ hideExcept h a action =
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
deriving instance Lift Versioning
deriving instance Lift Version
@@ -181,3 +206,12 @@ pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . pvp
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal

2
lib/GHCup/Types.hs
View File

@@ -17,7 +17,7 @@ data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
data Tag = Latest
| Recommended
deriving (Eq, Show)
deriving (Ord, Eq, Show)
data VersionInfo = VersionInfo
{ _viTags :: [Tag]

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

@@ -6,7 +6,8 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Types.JSON where
@@ -20,7 +21,11 @@ import Data.Text.Encoding ( decodeUtf8
)
import Data.Aeson.Types
import Data.Text.Encoding as E
import HPath
import URI.ByteString
import Data.Word8
import qualified Data.ByteString as BS
import Data.String.QQ
@@ -33,6 +38,9 @@ deriveJSON defaultOptions ''SemVer
deriveJSON defaultOptions ''Tool
deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo
instance ToJSON URI where
@@ -127,3 +135,17 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . 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