This commit is contained in:
Julian Ospald 2020-03-03 01:59:19 +01:00
parent d598c42d19
commit 62b249db2d
20 changed files with 1254 additions and 763 deletions

24
TODO.md
View File

@ -1,33 +1,39 @@
# TODOs and Remarks # TODOs and Remarks
## New ## Now
* better logs * better logs
* better debug-output * better debug-output
* download progress
* upgrade Upgrade this script in-place * upgrade Upgrade this script in-place
* reference tarballs in json
## Maybe
* maybe: download progress
* maybe: changelog Show the changelog of a GHC release (online) * maybe: changelog Show the changelog of a GHC release (online)
* maybe: print-system-reqs Print an approximation of system requirements * maybe: print-system-reqs Print an approximation of system requirements
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
## Later
## Old
* handling of SIGTERM and SIGUSR
* add support for RC/alpha/HEAD versions * add support for RC/alpha/HEAD versions
* check for updates on start
## Questions
* how to figure out tools (currently not done, but when setting ghc symlinks, removes all previous tools before symlinking requested version to avoid stale tools that only exist for one version)
* handling of SIGTERM and SIGUSR
* installing musl on demand?
* redo/rethink how tool tags works * redo/rethink how tool tags works
* mirror support * mirror support
* checksums
* check for new version on start * check for new version on start
* tarball tags as well as version tags? * tarball tags as well as version tags?
* installing multiple versions in parallel? * installing multiple versions in parallel?
* how to version and extend the format of the downloads file? Compatibility? * how to version and extend the format of the downloads file? Compatibility?
* how to propagate updates? Automatically? Might solve the versioning problem * how to propagate updates? Automatically? Might solve the versioning problem
* installing musl on demand?
* interactive handling when distro doesn't exist and we know the tarball is incompatible? * interactive handling when distro doesn't exist and we know the tarball is incompatible?
* ghcup-with wrapper to execute a command with a given ghc in PATH? * ghcup-with wrapper to execute a command with a given ghc in PATH?
* maybe add deprecation notice into JSON * maybe add deprecation notice into JSON

View File

@ -1,24 +1,20 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module AvailableDownloads where module BinaryDownloads where
import qualified Data.Map as M
import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude
import Data.String.QQ
import HPath import HPath
import URI.ByteString.QQ import URI.ByteString.QQ
import qualified Data.Map as M
-- TODO: version quasiquoter binaryDownloads :: BinaryDownloads
availableDownloads :: AvailableDownloads binaryDownloads = M.fromList
availableDownloads = M.fromList
[ ( GHC [ ( GHC
, M.fromList , M.fromList
[ ( [vver|8.6.5|] [ ( [vver|8.6.5|]
@ -31,6 +27,7 @@ availableDownloads = M.fromList
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|] [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)) (Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
) )
] ]
) )
@ -38,8 +35,9 @@ availableDownloads = M.fromList
, M.fromList , M.fromList
[ ( Nothing [ ( Nothing
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|] [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)) (Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
) )
] ]
) )
@ -49,11 +47,13 @@ availableDownloads = M.fromList
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|] [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 ([rel|ghc-8.6.5|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
) )
, ( Just $ [vers|8|] , ( Just $ [vers|8|]
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|] [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 ([rel|ghc-8.6.5|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
) )
] ]
) )
@ -62,7 +62,7 @@ availableDownloads = M.fromList
] ]
), ),
( [vver|8.4.4|] ( [vver|8.4.4|]
, VersionInfo [Latest] $ M.fromList , VersionInfo [] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ ( Linux UnknownLinux [ ( Linux UnknownLinux
@ -71,6 +71,7 @@ availableDownloads = M.fromList
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|] [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.4.4|] :: Path Rel)) (Just ([rel|ghc-8.4.4|] :: Path Rel))
[s|86785f41d228168461859e40956973fb|]
) )
] ]
) )
@ -78,8 +79,9 @@ availableDownloads = M.fromList
, M.fromList , M.fromList
[ ( Nothing [ ( Nothing
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|] [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.4.4|] :: Path Rel)) (Just ([rel|ghc-8.4.4|] :: Path Rel))
[s|f943a245c54c2f2dcb354dceeff886e1|]
) )
] ]
) )
@ -89,11 +91,13 @@ availableDownloads = M.fromList
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|] [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 ([rel|ghc-8.6.5|] :: Path Rel))
[s|f943a245c54c2f2dcb354dceeff886e1|]
) )
, ( Just $ [vers|8|] , ( Just $ [vers|8|]
, DownloadInfo , DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|] [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)) (Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|f943a245c54c2f2dcb354dceeff886e1|]
) )
] ]
) )
@ -115,6 +119,7 @@ availableDownloads = M.fromList
, DownloadInfo , 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|] [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 Nothing
[s|32352d2259909970e6ff04faf61bbfac|]
) )
] ]
) )

View File

@ -0,0 +1,11 @@
module GHCupDownloads where
import GHCup.Types
import BinaryDownloads
import SourceDownloads
ghcupDownloads :: GHCupDownloads
ghcupDownloads = GHCupDownloads { _binaryDownloads = binaryDownloads
, _sourceDownloads = sourceDownloads
}

View File

@ -8,19 +8,21 @@
module Main where module Main where
import AvailableDownloads import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import GHCupDownloads
import Data.Aeson ( eitherDecode ) import Data.Aeson ( eitherDecode )
import Data.Aeson.Encode.Pretty import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy as L
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import GHCup.Types.JSON ( )
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import GHCup.Logger
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import System.IO ( stdout ) import System.IO ( stdout )
import Validate import Validate
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
data Options = Options data Options = Options
@ -120,7 +122,7 @@ main = do
GenJSON gopts -> do GenJSON gopts -> do
let let
bs = encodePretty' (defConfig { confIndent = Spaces 2 }) bs = encodePretty' (defConfig { confIndent = Spaces 2 })
availableDownloads ghcupDownloads
case gopts of case gopts of
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
@ -140,4 +142,4 @@ main = do
av <- case eitherDecode contents of av <- case eitherDecode contents of
Right r -> pure r Right r -> pure r
Left e -> die (color Red $ show e) Left e -> die (color Red $ show e)
myLoggerTStdout (validate av) >>= exitWith myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith

View File

@ -0,0 +1,26 @@
{-# LANGUAGE QuasiQuotes #-}
module SourceDownloads where
import GHCup.Types
import GHCup.Utils.Prelude
import Data.String.QQ
import HPath
import URI.ByteString.QQ
import qualified Data.Map as M
-- TODO: source tarballs
-- TODO: reference tarballs
sourceDownloads :: SourceDownloads
sourceDownloads = M.fromList
[ ( [vver|8.6.5|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|b47726aaf302eb87b4970fcee924d45d|]
)
]

View File

@ -34,20 +34,23 @@ instance Exception ValidationError
-- TODO: test that GHC is in semver -- TODO: test that GHC is in semver
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m) validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
=> AvailableDownloads => GHCupDownloads
-> m ExitCode -> m ExitCode
validate av = do validate GHCupDownloads{..} = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
-- * verify binary downloads * --
flip runReaderT ref $ do flip runReaderT ref $ do
-- unique tags -- unique tags
forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t
-- required platforms -- required platforms
forM_ (M.toList av) $ \(t, versions) -> forM_ (M.toList _binaryDownloads) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) -> forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs) checkHasRequiredPlatforms t v arch (M.keys pspecs)
-- exit -- exit
e <- liftIO $ readIORef ref e <- liftIO $ readIORef ref
if e > 0 then pure $ ExitFailure e else pure ExitSuccess if e > 0 then pure $ ExitFailure e else pure ExitSuccess
@ -65,7 +68,7 @@ validate av = do
[i|FreeBSD missing for #{t} #{v'} #{arch}|] [i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions av tool let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
let nonUnique = let nonUnique =
fmap fst fmap fst
. filter (\(_, b) -> not b) . filter (\(_, b) -> not b)

View File

@ -9,10 +9,13 @@
module Main where module Main where
import GHCup import GHCup
import GHCup.File import GHCup.Download
import GHCup.Logger import GHCup.Errors
import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
@ -25,16 +28,19 @@ import Data.String.Interpolate
import Data.String.QQ import Data.String.QQ
import Data.Versions import Data.Versions
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import System.IO import System.IO
import Text.Read
import Text.Layout.Table import Text.Layout.Table
import URI.ByteString import URI.ByteString
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E
@ -56,6 +62,7 @@ data Command
| List ListOptions | List ListOptions
| Rm RmOptions | Rm RmOptions
| DInfo | DInfo
| Compile CompileOptions
data ToolVersion = ToolVersion Version data ToolVersion = ToolVersion Version
| ToolTag Tag | ToolTag Tag
@ -82,6 +89,14 @@ data RmOptions = RmOptions
} }
data CompileOptions = CompileOptions
{ ghcVer :: Version
, bootstrapVer :: Version
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
}
opts :: Parser Options opts :: Parser Options
opts = opts =
Options Options
@ -139,6 +154,13 @@ com =
(progDesc "Remove a GHC version installed by ghcup") (progDesc "Remove a GHC version installed by ghcup")
) )
) )
<> command
"compile"
( Compile
<$> (info (compileOpts <**> helper)
(progDesc "Compile GHC from source")
)
)
<> commandGroup "GHC commands:" <> commandGroup "GHC commands:"
<> hidden <> hidden
) )
@ -195,17 +217,50 @@ listOpts =
) )
rmOpts :: Parser RmOptions rmOpts :: Parser RmOptions
rmOpts = rmOpts = RmOptions <$> versionParser
RmOptions
compileOpts :: Parser CompileOptions
compileOpts =
CompileOptions
<$> (option <$> (option
(eitherReader (eitherReader
(bimap (const "Not a valid version") id . version . T.pack) (bimap (const "Not a valid version") id . version . T.pack)
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to remove" "The GHC version to compile"
)
)
<*> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
( short 'b'
<> long "bootstrap-version"
<> metavar "BOOTSTRAP_VERSION"
<> help "The GHC version to bootstrap with (must be installed)"
)
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> optional
(option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
) )
) )
versionParser :: Parser Version versionParser :: Parser Version
@ -285,6 +340,7 @@ main = do
, ProcessError , ProcessError
, TagNotFound , TagNotFound
, URLException , URLException
, DigestError
] ]
let runSetGHC = let runSetGHC =
@ -313,13 +369,31 @@ main = do
. runE . runE
@'[PlatformResultError , NoCompatibleArch , DistroNotFound] @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, NotInstalled
, GHCNotFound
, ArchiveError
, ProcessError
, URLException
, DigestError
, BuildConfigNotFound
, FileDoesNotExistError
, URLException
, JSONError
]
case optCommand of case optCommand of
Install (InstallGHC InstallOptions {..}) -> Install (InstallGHC InstallOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
av <- liftE getDownloads dls <- _binaryDownloads <$> liftE getDownloads
v <- liftE $ fromVersion av instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installTool (ToolRequest GHC v) Nothing liftE $ installTool dls (ToolRequest GHC v) Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
@ -329,12 +403,12 @@ main = do
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure
Install (InstallGHC InstallOptions {..}) -> Install (InstallCabal InstallOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
av <- liftE getDownloads dls <- _binaryDownloads <$> liftE getDownloads
v <- liftE $ fromVersion av instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installTool (ToolRequest Cabal v) Nothing liftE $ installTool dls (ToolRequest Cabal v) Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
@ -348,8 +422,8 @@ main = do
SetGHC (SetGHCOptions {..}) -> SetGHC (SetGHCOptions {..}) ->
void void
$ (runSetGHC $ do $ (runSetGHC $ do
av <- liftE getDownloads dls <- _binaryDownloads <$> liftE getDownloads
v <- liftE $ fromVersion av ghcVer GHC v <- liftE $ fromVersion dls ghcVer GHC
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly
) )
>>= \case >>= \case
@ -361,7 +435,8 @@ main = do
List (ListOptions {..}) -> List (ListOptions {..}) ->
void void
$ (runListGHC $ do $ (runListGHC $ do
liftE $ listVersions lTool lCriteria dls <- _binaryDownloads <$> liftE getDownloads
liftIO $ listVersions dls lTool lCriteria
) )
>>= \case >>= \case
VRight r -> liftIO $ printListResult r VRight r -> liftIO $ printListResult r
@ -387,11 +462,28 @@ main = do
VRight dinfo -> putStrLn $ show dinfo VRight dinfo -> putStrLn $ show dinfo
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileOptions {..}) ->
void
$ (runCompileGHC $ do
dls <- _sourceDownloads <$> liftE getDownloads
liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|GHC successfully compiled and installed|])
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
pure () pure ()
fromVersion :: Monad m fromVersion :: Monad m
=> AvailableDownloads => BinaryDownloads
-> Maybe ToolVersion -> Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound] m Version -> Excepts '[TagNotFound] m Version

View File

@ -33,6 +33,7 @@ common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 } common generics-sop { build-depends: generics-sop >= 0.5 }
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 } common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
common hopenssl { build-depends: hopenssl >= 2.2.4 }
common hpath { build-depends: hpath >= 0.11 } common hpath { build-depends: hpath >= 0.11 }
common hpath-directory { build-depends: hpath-directory >= 0.13.2 } common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
@ -53,6 +54,7 @@ common resourcet { build-depends: resourcet >= 1.2.2 }
common safe { build-depends: safe >= 0.3.18 } common safe { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } common streamly { build-depends: streamly >= 0.7 }
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 } common strict-base { build-depends: strict-base >= 0.4 }
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 } common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
@ -101,6 +103,7 @@ library
, generics-sop , generics-sop
, haskus-utils-types , haskus-utils-types
, haskus-utils-variant , haskus-utils-variant
, hopenssl
, hpath , hpath
, hpath-directory , hpath-directory
, hpath-filepath , hpath-filepath
@ -120,6 +123,7 @@ library
, safe , safe
, safe-exceptions , safe-exceptions
, streamly , streamly
, streamly-posix
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-interpolate , string-interpolate
@ -138,13 +142,17 @@ library
, word8 , word8
, zlib , zlib
exposed-modules: GHCup exposed-modules: GHCup
GHCup.Bash GHCup.Download
GHCup.File GHCup.Errors
GHCup.Logger GHCup.Platform
GHCup.Prelude
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.File
GHCup.Utils.Logger
GHCup.Utils.Prelude
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
hs-source-dirs: lib hs-source-dirs: lib
@ -201,7 +209,9 @@ executable ghcup-gen
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
main-is: Main.hs main-is: Main.hs
other-modules: AvailableDownloads other-modules: BinaryDownloads
GHCupDownloads
SourceDownloads
Validate Validate
-- other-extensions: -- other-extensions:
build-depends: ghcup build-depends: ghcup

View File

@ -12,12 +12,15 @@
module GHCup where module GHCup where
import GHCup.Bash import GHCup.Download
import GHCup.File import GHCup.Errors
import GHCup.Prelude import GHCup.Platform
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -28,510 +31,32 @@ import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.Aeson
import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.ByteString.Builder
import Data.Foldable import Data.Foldable
import Data.IORef
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
import Data.String.QQ import Data.String.QQ
import Data.Text ( Text )
import Data.Versions import Data.Versions
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
import HPath.IO import HPath.IO
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, readFile , readFile
, writeFile
) )
import Safe
import System.IO.Error import System.IO.Error
import System.Info import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.Env.ByteString ( getEnv ) import System.Posix.FilePath ( getSearchPath )
import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink )
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import System.Posix.RawFilePath.Directory.Errors import System.Posix.RawFilePath.Directory.Errors
( hideError ) ( hideError )
import System.Posix.Types
import URI.ByteString
import URI.ByteString.QQ
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.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU
import qualified System.IO.Streams as Streams
import qualified System.Posix.FilePath as FP
import qualified System.Posix.RawFilePath.Directory
as RD
data Settings = Settings
{ cache :: Bool
, urlSource :: URLSource
}
deriving Show
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
---------------------------
--[ Excepts Error types ]--
---------------------------
data PlatformResultError = NoCompatiblePlatform String
deriving Show
data NoDownload = NoDownload
deriving Show
data NoCompatibleArch = NoCompatibleArch String
deriving Show
data DistroNotFound = DistroNotFound
deriving Show
data ArchiveError = UnknownArchive ByteString
deriving Show
data URLException = UnsupportedURL
deriving Show
data FileError = CopyError String
deriving Show
data TagNotFound = TagNotFound Tag Tool
deriving Show
data AlreadyInstalled = AlreadyInstalled ToolRequest
deriving Show
data NotInstalled = NotInstalled ToolRequest
deriving Show
data NotSet = NotSet Tool
deriving Show
data JSONError = JSONDecodeError String
deriving Show
data ParseError = ParseError String
deriving Show
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
instance Exception ParseError
--------------------------------
--[ AvailableDownloads stuff ]--
--------------------------------
ghcupURL :: URI
ghcupURL =
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
-- | Get the tool versions that have this tag.
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: AvailableDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: AvailableDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadReader Settings m
)
=> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
AvailableDownloads
getDownloads = lift getUrlSource >>= \case
GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- liftE $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
----------------------
--[ Download stuff ]--
----------------------
getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
=> ToolRequest
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, FileDoesNotExistError
, JSONError
, NoCompatibleArch
, NoDownload
, PlatformResultError
, URLException
]
m
DownloadInfo
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
Nothing -> do
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
dls <- liftE $ getDownloads
lE $ getDownloadInfo' t v arch' plat ver dls
getDownloadInfo' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> 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
-- | 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
| 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
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL
let path = view (dlUri % pathL') dli
let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
liftIO $ download' https host path port dest mfn
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[FileDoesNotExistError , URLException]
m
L.ByteString
downloadBS uri'
| scheme == [s|https|]
= dl True
| scheme == [s|http|]
= dl False
| scheme == [s|file|]
= liftException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
| otherwise
= throwE UnsupportedURL
where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
?? UnsupportedURL
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 :: IO (Fd, Path Abs)
getFile = do
-- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of
-- if a filename was provided, try that
Just x ->
let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...otherwise try to infer the filename from the URL path
fn' <- urlBaseName path
let fp = dest </> fn'
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
(\_ i' -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ consumer bs
Nothing -> pure ()
)
Streams.connect i' outStream
)
closeConnection c
--------------------------
--[ 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
'[PlatformResultError , 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
| 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)
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined
@ -554,7 +79,8 @@ installTool :: ( MonadThrow m
, MonadFail m , MonadFail m
, MonadResource m , MonadResource m
) -- tmp file ) -- tmp file
=> ToolRequest => BinaryDownloads
-> ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
@ -569,10 +95,11 @@ installTool :: ( MonadThrow m
, PlatformResultError , PlatformResultError
, ProcessError , ProcessError
, URLException , URLException
, DigestError
] ]
m m
() ()
installTool treq mpfReq = do installTool bDls treq mpfReq = do
lift $ $(logDebug) [i|Requested to install: #{treq}|] lift $ $(logDebug) [i|Requested to install: #{treq}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq) when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
@ -580,39 +107,24 @@ installTool treq mpfReq = do
Settings {..} <- lift ask Settings {..} <- lift ask
-- download (or use cached version) -- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo treq mpfReq dlinfo <- liftE $ getDownloadInfo bDls treq mpfReq
dl <- case cache of dl <- liftE $ downloadCached dlinfo Nothing
True -> do
cachedir <- liftIO $ ghcupCacheDir
fn <- urlBaseName $ view (dlUri % pathL') dlinfo
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> pure $ cachfile
| otherwise -> liftE $ download dlinfo cachedir Nothing
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dlinfo tmp Nothing
-- unpack -- unpack
unpacked <- liftE $ unpackToTmpDir dl tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
-- prepare paths -- prepare paths
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq) ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo) let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
case treq of case treq of
(ToolRequest GHC ver) -> do (ToolRequest GHC ver) -> do
liftE $ installGHC archiveSubdir ghcdir liftE $ installGHC archiveSubdir ghcdir
liftE $ setGHC ver SetGHCMinor liftE $ postGHCInstall ver
-- 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 _) -> liftE $ installCabal archiveSubdir bindir (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
@ -632,10 +144,11 @@ installGHC :: (MonadLogger m, MonadIO m)
installGHC path inst = do installGHC path inst = do
lift $ $(logInfo) [s|Installing GHC|] lift $ $(logInfo) [s|Installing GHC|]
lEM $ liftIO $ exec [s|./configure|] lEM $ liftIO $ exec [s|./configure|]
[[s|--prefix=|] <> toFilePath inst]
False False
[[s|--prefix=|] <> toFilePath inst]
(Just path) (Just path)
lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path) Nothing
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
pure () pure ()
@ -679,13 +192,15 @@ setGHC ver sghc = do
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination -- symlink destination
destdir <- liftIO $ ghcupBinDir bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do forM_ verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file) liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
targetFile <- case sghc of targetFile <- case sghc of
SetGHCOnly -> pure file SetGHCOnly -> pure file
SetGHCMajor -> do SetGHCMajor -> do
@ -695,8 +210,8 @@ setGHC ver sghc = do
parseRel (toFilePath file <> B.singleton _hyphen <> major') parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ hideError doesNotExistErrorType $ deleteFile liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> targetFile) (bindir </> targetFile)
liftIO $ createSymlink (destdir </> targetFile) liftIO $ createSymlink (bindir </> targetFile)
(ghcLinkDestination (toFilePath file) ver) (ghcLinkDestination (toFilePath file) ver)
-- create symlink for share dir -- create symlink for share dir
@ -721,6 +236,18 @@ setGHC ver sghc = do
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir) ([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> pure () _ -> pure ()
-- The old tool symlinks might be different (e.g. more) than the
-- requested version. Have to avoid "stray" symlinks.
delOldSymlinks :: forall m
. (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> Excepts '[] m ()
delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
mv <- ghcSet
for_ mv $ \ver' -> do
verfiles <- ghcToolFiles ver'
for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
@ -743,34 +270,22 @@ data ListResult = ListResult
deriving Show deriving Show
availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])] availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf availableToolVersions av tool = toListOf
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded) (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
av av
listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m) listVersions :: BinaryDownloads
=> Maybe Tool
-> Maybe ListCriteria
-> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
[ListResult]
listVersions lt criteria = do
dls <- liftE $ getDownloads
liftIO $ listVersions' dls lt criteria
listVersions' :: AvailableDownloads
-> Maybe Tool -> Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
-> IO [ListResult] -> IO [ListResult]
listVersions' av lt criteria = case lt of listVersions av lt criteria = case lt of
Just t -> do Just t -> do
filter' <$> forM (availableToolVersions av t) (toListResult t) filter' <$> forM (availableToolVersions av t) (toListResult t)
Nothing -> do Nothing -> do
ghcvers <- listVersions' av (Just GHC) criteria ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions' av (Just Cabal) criteria cabalvers <- listVersions av (Just Cabal) criteria
pure (ghcvers <> cabalvers) pure (ghcvers <> cabalvers)
where where
@ -897,167 +412,116 @@ getDebugInfo = do
----------------- ---------------
--[ Utilities ]-- --[ Compile ]--
----------------- ---------------
ghcupBaseDir :: IO (Path Abs) -- TODO: build config
ghcupBaseDir = do compileGHC :: ( MonadReader Settings m
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case , MonadThrow m
Just r -> parseAbs r , MonadResource m
Nothing -> do , MonadLogger m
home <- liftIO getHomeDirectory , MonadIO m
pure (home </> ([rel|.ghcup|] :: Path Rel)) , MonadFail m
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)
-- | 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))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
cabalInstalled :: Version -> IO Bool
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 == (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 (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 => SourceDownloads
-> Version -- ^ version to install
-> Version -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
-> Excepts
'[ AlreadyInstalled
, NotInstalled
, GHCNotFound
, ArchiveError
, ProcessError
, URLException
, DigestError
, BuildConfigNotFound
]
m
()
compileGHC dls tver bver jobs mbuildConfig = do
let treq = ToolRequest GHC tver
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
-- download source tarball
dlInfo <- preview (ix tver) dls ?? GHCNotFound
dl <- liftE $ downloadCached dlInfo Nothing
urlBaseName :: MonadThrow m -- unpack
=> ByteString -- ^ the url path (without scheme and host) tmpUnpack <- lift mkGhcupTmpDir
-> m (Path Rel) liftE $ unpackToDir tmpUnpack dl
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
-- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: (MonadResource m -- temp file
, MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do
let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|]
fn <- toFilePath <$> basename av
tmp <- toFilePath <$> lift withGHCupTmpDir
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
parseAbs tmp
-- extract, depending on file extension
if if
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO | tver >= [vver|8.8.0|] -> do
(untar . GZip.decompress =<< readFile av) cEnv <- liftIO $ getEnvironment
| [s|.tar.xz|] `B.isSuffixOf` fn -> do spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
filecontents <- liftIO $ readFile av bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
let decompressed = Lzma.decompress filecontents let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
liftIO $ untar decompressed lEM $ liftIO $ exec [s|./configure|]
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO False
(untar . BZip.decompress =<< readFile av) [[s|--prefix=|] <> toFilePath ghcdir]
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av) (Just workdir)
| otherwise -> throwE $ UnknownArchive fn (Just newEnv)
| otherwise -> do
lEM $ liftIO $ exec
[s|./configure|]
False
[ [s|--prefix=|] <> toFilePath ghcdir
, [s|--with-ghc=|] <> toFilePath bghc
]
(Just workdir)
Nothing
let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
case mbuildConfig of
Just bc -> liftIO $ copyFile bc build_mk Overwrite
Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf
lEM $ liftIO $ exec [s|make|]
True
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
(Just workdir)
Nothing
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing
liftE $ postGHCInstall tver
pure ()
where
defaultConf = [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES
GhcWithLlvmCodeGen = YES|]
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) -------------
--[ Other ]--
-------------
-- | Creates ghc-x.y.z and ghc-x.y symlinks.
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m ()
ghcToolFiles ver = do postGHCInstall ver = do
ghcdir <- liftIO $ ghcupGHCDir ver liftE $ setGHC ver SetGHCMinor
-- fail if ghc is not installed -- Create ghc-x.y symlinks. This may not be the current
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir) -- version, create it regardless.
(throwE (NotInstalled $ ToolRequest GHC ver)) (mj, mi) <- liftIO $ getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
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

337
lib/GHCup/Download.hs Normal file
View File

@ -0,0 +1,337 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
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 Control.Applicative
import Control.Exception.Safe
import Control.Monad
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.IORef
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
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.Posix.Types
import URI.ByteString
import URI.ByteString.QQ
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Encoding as E
import qualified System.IO.Streams as Streams
import qualified System.Posix.RawFilePath.Directory
as RD
ghcupURL :: URI
ghcupURL =
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
-- | Downloads the download information!
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
)
=> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
GHCupDownloads
getDownloads = do
urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- liftE $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
=> BinaryDownloads
-> ToolRequest
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, FileDoesNotExistError
, JSONError
, NoCompatibleArch
, NoDownload
, PlatformResultError
, URLException
]
m
DownloadInfo
getDownloadInfo bDls (ToolRequest 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
-> BinaryDownloads
-> 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
-- | 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 '[DigestError , 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
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL
let path = view (dlUri % pathL') dli
let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
p <- liftIO $ download' https host path port dest mfn
-- TODO: verify md5 during download
let p' = toFilePath p
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
c <- liftIO $ readFile p
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
eDigest = view dlHash dli
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
pure p
-- | Download or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadResource m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader Settings m
)
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , URLException] 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
let cachfile' = toFilePath cachfile
lift $ $(logInfo) [i|veryfing digest of: #{cachfile'}|]
c <- liftIO $ readFile cachfile
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
eDigest = view dlHash dli
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
pure $ cachfile
| otherwise
-> liftE $ download dli cachedir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[FileDoesNotExistError , URLException]
m
L.ByteString
downloadBS uri'
| scheme == [s|https|]
= dl True
| scheme == [s|http|]
= dl False
| scheme == [s|file|]
= liftException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
| otherwise
= throwE UnsupportedURL
where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
?? UnsupportedURL
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 :: IO (Fd, Path Abs)
getFile = do
-- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of
-- if a filename was provided, try that
Just x ->
let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...otherwise try to infer the filename from the URL path
fn' <- urlBaseName path
let fp = dest </> fn'
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
(\_ i' -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ consumer bs
Nothing -> pure ()
)
Streams.connect i' outStream
)
closeConnection c

63
lib/GHCup/Errors.hs Normal file
View File

@ -0,0 +1,63 @@
module GHCup.Errors where
import GHCup.Types
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import HPath
-- | A compatible platform could not be found.
data PlatformResultError = NoCompatiblePlatform String -- the platform we got
deriving Show
data NoDownload = NoDownload
deriving Show
data NoCompatibleArch = NoCompatibleArch String
deriving Show
data DistroNotFound = DistroNotFound
deriving Show
data ArchiveError = UnknownArchive ByteString
deriving Show
data URLException = UnsupportedURL
deriving Show
data FileError = CopyError String
deriving Show
data TagNotFound = TagNotFound Tag Tool
deriving Show
data AlreadyInstalled = AlreadyInstalled ToolRequest
deriving Show
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
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data GHCNotFound = GHCNotFound
deriving Show
data BuildConfigNotFound = BuildConfigNotFound (Path Abs)
deriving Show
data DigestError = DigestError Text Text
deriving Show

165
lib/GHCup/Platform.hs Normal file
View File

@ -0,0 +1,165 @@
{-# 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 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.String.QQ
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
'[PlatformResultError , 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
| 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)

View File

@ -3,6 +3,7 @@
module GHCup.Types where module GHCup.Types where
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.Text ( Text )
import Data.Versions import Data.Versions
import HPath import HPath
import URI.ByteString import URI.ByteString
@ -10,6 +11,14 @@ import URI.ByteString
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
data Settings = Settings
{ cache :: Bool
, urlSource :: URLSource
}
deriving Show
data DebugInfo = DebugInfo data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs { diBaseDir :: Path Abs
, diBinDir :: Path Abs , diBinDir :: Path Abs
@ -25,7 +34,7 @@ data DebugInfo = DebugInfo
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc' data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHCMajor -- ^ ghc-x.y | SetGHCMajor -- ^ ghc-x.y
| SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
deriving Show deriving (Eq, Show)
data Tag = Latest data Tag = Latest
@ -41,10 +50,12 @@ data VersionInfo = VersionInfo
data DownloadInfo = DownloadInfo data DownloadInfo = DownloadInfo
{ _dlUri :: URI { _dlUri :: URI
, _dlSubdir :: Maybe (Path Rel) , _dlSubdir :: Maybe (Path Rel)
, _dlHash :: Text
} }
deriving (Eq, Show) deriving (Eq, Show)
data Tool = GHC data Tool = GHC
| GHCSrc
| Cabal | Cabal
| GHCUp | GHCUp
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
@ -98,10 +109,17 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version VersionInfo type ToolVersionSpec = Map Version VersionInfo
type AvailableDownloads = Map Tool ToolVersionSpec type BinaryDownloads = Map Tool ToolVersionSpec
type SourceDownloads = Map Version DownloadInfo
data GHCupDownloads = GHCupDownloads {
_binaryDownloads :: BinaryDownloads
, _sourceDownloads :: SourceDownloads
} deriving Show
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource URI
| OwnSpec AvailableDownloads | OwnSpec GHCupDownloads
deriving Show deriving Show

View File

@ -41,6 +41,7 @@ deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo deriveJSON defaultOptions ''DownloadInfo
deriveJSON defaultOptions ''GHCupDownloads
instance ToJSON URI where instance ToJSON URI where

View File

@ -19,6 +19,7 @@ makeLenses ''ToolRequest
makeLenses ''DownloadInfo makeLenses ''DownloadInfo
makeLenses ''Tag makeLenses ''Tag
makeLenses ''VersionInfo makeLenses ''VersionInfo
makeLenses ''GHCupDownloads
uriSchemeL' :: Lens' (URIRef Absolute) Scheme uriSchemeL' :: Lens' (URIRef Absolute) Scheme

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

@ -0,0 +1,240 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Prelude
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.String.QQ
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.Posix.Env.ByteString ( getEnv )
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
-----------------
--[ Utilities ]--
-----------------
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)
-- | 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))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
cabalInstalled :: Version -> IO Bool
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 == (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 (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
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- | 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 '[ArchiveError] 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
-- 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
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
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache

View File

@ -1,4 +1,4 @@
module GHCup.Bash module GHCup.Utils.Bash
( findAssignment ( findAssignment
, equalsAssignmentWith , equalsAssignmentWith
, getRValue , getRValue

View File

@ -1,7 +1,9 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module GHCup.File where module GHCup.Utils.File where
import GHCup.Utils.Prelude
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
@ -16,13 +18,13 @@ import Data.Maybe
import Data.String.QQ import Data.String.QQ
import GHC.Foreign ( peekCStringLen ) import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding ) import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
import HPath import HPath
import HPath.IO import HPath.IO
import Optics import Optics
import Streamly import Streamly
import Streamly.External.ByteString import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy import Streamly.External.ByteString.Lazy
import System.Exit
import System.IO import System.IO
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
import System.Posix.Env.ByteString import System.Posix.Env.ByteString
@ -40,6 +42,7 @@ import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import qualified System.Posix.FilePath as FP import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU import qualified System.Posix.User as PU
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream import qualified Streamly.Internal.Memory.ArrayStream
as AS as AS
import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.FileSystem.Handle as FH
@ -163,15 +166,17 @@ createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm) FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
-- | Thin wrapper around `executeFile`.
exec :: ByteString -- ^ thing to execute exec :: ByteString -- ^ thing to execute
-> [ByteString] -- ^ args for the thing
-> Bool -- ^ whether to search PATH for the thing -> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ()) -> IO (Either ProcessError ())
exec exe args spath chdir = do exec exe spath args chdir env = do
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args Nothing SPPB.executeFile exe spath args env
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
@ -192,7 +197,6 @@ mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|]) tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
liftIO $ System.IO.putStrLn $ show tmp
parseAbs tmp parseAbs tmp
@ -216,3 +220,25 @@ unsafePathToString :: Path b -> IO FilePath
unsafePathToString (Path p) = do unsafePathToString (Path p) = do
enc <- getLocaleEncoding enc <- getLocaleEncoding
unsafeUseAsCStringLen p (peekCStringLen enc) unsafeUseAsCStringLen 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

View File

@ -1,4 +1,4 @@
module GHCup.Logger where module GHCup.Utils.Logger where
import Control.Monad.Logger import Control.Monad.Logger

View File

@ -11,7 +11,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module GHCup.Prelude where module GHCup.Utils.Prelude where
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -29,7 +29,9 @@ import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..) , Lift) import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
)
import System.IO.Error import System.IO.Error
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -163,6 +165,16 @@ liftException errType ex =
. liftE . liftE
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? -- TODO: does this work?
hideExcept :: forall e es es' a m hideExcept :: forall e es es' a m
. (Monad m, e :< es, LiftVariant (Remove e es) es') . (Monad m, e :< es, LiftVariant (Remove e es) es')
@ -173,6 +185,15 @@ hideExcept :: forall e es es' a m
hideExcept _ a action = hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m 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
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of throwEither a = case a of