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

Lala

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

10
TODO.md
View File

@ -2,20 +2,17 @@
## Now ## Now
* better logs * static builds and host ghcup (and fix BinaryDownloads)
* better debug-output
* static builds
* interoperability with old ghcup * interoperability with old ghcup
* OS faking * sign the JSON? (Or check gpg keys?)
## Maybe ## Maybe
* maybe: download progress * 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
* OS faking
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
@ -23,6 +20,7 @@
* add support for RC/alpha/HEAD versions * add support for RC/alpha/HEAD versions
* check for updates on start * check for updates on start
* use plucky or oops instead of Excepts
## Questions ## Questions

85
app/ghcup-gen/BinaryDownloads.hs
View File

@ -4,9 +4,9 @@
module BinaryDownloads where module BinaryDownloads where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Data.String.QQ
import HPath import HPath
import URI.ByteString.QQ import URI.ByteString.QQ
@ -95,7 +95,7 @@ ghc_802_32_deb8 :: DownloadInfo
ghc_802_32_deb8 = DownloadInfo ghc_802_32_deb8 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-i386-deb8-linux.tar.xz|] [uri|https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-i386-deb8-linux.tar.xz|]
(Just ([rel|ghc-8.0.2|] :: Path Rel)) (Just ([rel|ghc-8.0.2|] :: Path Rel))
[s||818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|] [s|818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|]
ghc_802_64_freebsd :: DownloadInfo ghc_802_64_freebsd :: DownloadInfo
ghc_802_64_freebsd = DownloadInfo ghc_802_64_freebsd = DownloadInfo
@ -827,7 +827,8 @@ ghc_883_32_musl :: DownloadInfo
ghc_883_32_musl = DownloadInfo ghc_883_32_musl = DownloadInfo
[uri|https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-i386-unknown-linux-musl.tar.xz|] [uri|https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-i386-unknown-linux-musl.tar.xz|]
(Just ([rel|ghc-8.8.3|] :: Path Rel)) (Just ([rel|ghc-8.8.3|] :: Path Rel))
[s|7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4|] [s|23779adb4cf4b314d0f8c66ee215ba6e74154c0768a573780475943544020bec|]
@ -900,8 +901,10 @@ cabal_3000_64_darwin = DownloadInfo
ghcup_010_64_linux :: DownloadInfo ghcup_010_64_linux :: DownloadInfo
ghcup_010_64_linux = ghcup_010_64_linux = DownloadInfo
DownloadInfo [uri|file:///home/ospa_ju/tmp/ghcup-exe|] Nothing [s||] [uri|file:///home/ospa_ju/tmp/ghcup-exe|]
Nothing
[s|558126339252788a3d44a3f910417277c7ab656f0796b68bdc58afe73296b8cd|]
@ -1023,12 +1026,12 @@ binaryDownloads = M.fromList
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_841_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_841_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Ubuntu, M.fromList [(Nothing, ghc_841_64_fedora)]) , (Linux Ubuntu , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)]) , (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Debian, M.fromList [(Nothing, ghc_841_64_deb8)]) , (Linux Debian , M.fromList [(Nothing, ghc_841_64_deb8)])
, (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)]) , (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)])
, (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)]) , (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)])
, (Linux Alpine, M.fromList [(Nothing, ghc_841_64_musl)]) , (Linux Alpine , M.fromList [(Nothing, ghc_841_64_musl)])
] ]
) )
, ( A_32 , ( A_32
@ -1118,9 +1121,9 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_844_64_fedora) [ (Nothing , ghc_844_64_fedora)
@ -1156,7 +1159,7 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_861_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_861_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_861_64_fedora) [ (Nothing , ghc_861_64_fedora)
@ -1192,7 +1195,7 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_862_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_862_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_862_64_fedora) [ (Nothing , ghc_862_64_fedora)
@ -1222,9 +1225,9 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_863_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_863_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_863_64_fedora) [ (Nothing , ghc_863_64_fedora)
@ -1260,7 +1263,7 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_864_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_864_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_864_64_fedora) [ (Nothing , ghc_864_64_fedora)
@ -1291,13 +1294,13 @@ binaryDownloads = M.fromList
] ]
) )
, ( [vver|8.6.5|] , ( [vver|8.6.5|]
, VersionInfo [] $ M.fromList , VersionInfo [Recommended] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_865_64_fedora) [ (Nothing , ghc_865_64_fedora)
@ -1332,9 +1335,9 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_881_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_881_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_881_64_fedora) [ (Nothing , ghc_881_64_fedora)
@ -1369,9 +1372,9 @@ binaryDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_882_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_882_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_882_64_fedora) [ (Nothing , ghc_882_64_fedora)
@ -1402,13 +1405,13 @@ binaryDownloads = M.fromList
] ]
) )
, ( [vver|8.8.3|] , ( [vver|8.8.3|]
, VersionInfo [] $ M.fromList , VersionInfo [Latest] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_883_64_fedora)]) [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_883_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)]) , (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)]) , (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)])
, ( Linux Ubuntu , ( Linux Ubuntu
, M.fromList , M.fromList
[ (Nothing , ghc_883_64_fedora) [ (Nothing , ghc_883_64_fedora)
@ -1443,17 +1446,15 @@ binaryDownloads = M.fromList
, ( Cabal , ( Cabal
, M.fromList , M.fromList
[ ( [vver|2.4.1.0|] [ ( [vver|2.4.1.0|]
, VersionInfo [Recommended, Latest] $ M.fromList , VersionInfo [] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ ( Linux UnknownLinux [ ( Linux UnknownLinux
, M.fromList [(Nothing, cabal_2410_64_linux)] , M.fromList [(Nothing, cabal_2410_64_linux)]
) )
, ( Linux Alpine , (Linux Alpine, M.fromList [(Nothing, cabal_2410_64_alpine)])
, M.fromList [(Nothing, cabal_2410_64_alpine)] , (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)])
) , (FreeBSD , M.fromList [(Nothing, cabal_2410_64_freebsd)])
, (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)])
, (FreeBSD, M.fromList [(Nothing, cabal_2410_64_freebsd)])
] ]
) )
, ( A_32 , ( A_32
@ -1489,7 +1490,7 @@ binaryDownloads = M.fromList
, ( GHCup , ( GHCup
, M.fromList , M.fromList
[ ( [vver|0.1.0|] [ ( [vver|0.1.0|]
, VersionInfo [Latest] $ M.fromList , VersionInfo [Recommended, Latest] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])] [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]

33
app/ghcup-gen/Main.hs
View File

@ -21,7 +21,7 @@ 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 as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -31,6 +31,7 @@ data Options = Options
data Command = GenJSON GenJSONOpts data Command = GenJSON GenJSONOpts
| ValidateJSON ValidateJSONOpts | ValidateJSON ValidateJSONOpts
| ValidateTarballs ValidateJSONOpts
data Output data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
@ -107,7 +108,16 @@ com = subparser
"check" "check"
( ValidateJSON ( ValidateJSON
<$> (info (validateJSONOpts <**> helper) <$> (info (validateJSONOpts <**> helper)
(progDesc "Generate the json downloads file") (progDesc "Validate the JSON")
)
)
)
<> (command
"check-tarballs"
( ValidateTarballs
<$> (info
(validateJSONOpts <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
) )
) )
) )
@ -130,16 +140,25 @@ main = do
L.writeFile file bs L.writeFile file bs
ValidateJSON vopts -> case vopts of ValidateJSON vopts -> case vopts of
ValidateJSONOpts { input = Nothing } -> ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just StdInput } -> ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just (FileInput file) } -> ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit L.readFile file >>= valAndExit validate
ValidateTarballs vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validateTarballs
pure () pure ()
where where
valAndExit contents = do valAndExit f contents = 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)
myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith

4
app/ghcup-gen/SourceDownloads.hs
View File

@ -4,9 +4,9 @@ module SourceDownloads where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Data.String.QQ
import HPath import HPath
import URI.ByteString.QQ import URI.ByteString.QQ

119
app/ghcup-gen/Validate.hs
View File

@ -5,42 +5,50 @@
module Validate where module Validate where
import GHCup import GHCup
import GHCup.Download
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Logger
import Control.Monad
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad.Reader.Class import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT ) import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.IORef
import Data.List import Data.List
import Data.String.Interpolate import Data.String.Interpolate
import Data.Versions import Data.Versions
import Data.IORef import Haskus.Utils.Variant.Excepts
import Optics
import System.Exit import System.Exit
import Control.Monad.Logger import System.IO
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
-- TODO: improve logging
data ValidationError = InternalError String data ValidationError = InternalError String
deriving Show deriving Show
instance Exception ValidationError instance Exception ValidationError
-- TODO: test that GHC is in semver addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
-- TODO: check there's LATEST tag for every tool addError = do
-- TODO: check all tarballs can be downloaded ref <- ask
-- AND their checksum liftIO $ modifyIORef ref (+ 1)
-- TODO: check gpg keys of tarballs?
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads => GHCupDownloads
-> m ExitCode -> m ExitCode
validate GHCupDownloads{..} = do validate dls@GHCupDownloads {..} = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
-- * verify binary downloads * -- -- * verify binary downloads * --
@ -54,10 +62,16 @@ validate GHCupDownloads{..} = do
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)
checkGHCisSemver
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t
-- 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 do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where where
checkHasRequiredPlatforms t v arch pspecs = do checkHasRequiredPlatforms t v arch pspecs = do
let v' = prettyVer v let v' = prettyVer v
@ -65,10 +79,10 @@ validate GHCupDownloads{..} = do
lift $ $(logError) lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|] [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
addError addError
when (not $ any (== Darwin) pspecs) $ do when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|] lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
addError addError
when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn) when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|] [i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do checkUniqueTags tool = do
@ -89,14 +103,75 @@ validate GHCupDownloads{..} = do
case join nonUnique of case join nonUnique of
[] -> pure () [] -> pure ()
xs -> do xs -> do
lift $ $(logError) [i|Tags not unique: #{xs}|] lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError addError
where where
isUniqueTag Latest = True isUniqueTag Latest = True
isUniqueTag Recommended = True isUniqueTag Recommended = True
checkGHCisSemver = do
let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v -> case semver (prettyVer v) of
Left _ -> do
lift $ $(logError) [i|GHC version #{v} is not valid semver|]
addError
Right _ -> pure ()
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m () -- a tool must have at least one of each mandatory tags
addError = do checkMandatoryTags tool = do
ref <- ask let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
liftIO $ modifyIORef ref (+ 1) forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
addError
True -> pure ()
validateTarballs :: ( Monad m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
)
=> GHCupDownloads
-> m ExitCode
validateTarballs GHCupDownloads {..} = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let
dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions ->
join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs ->
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
forM_ dlis $ downloadAll
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
downloadAll dli = do
let settings = Settings True GHCupURL False
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
}
r <-
runLogger
. flip runReaderT settings
. runResourceT
. runE
$ downloadCached dli Nothing
case r of
VRight _ -> pure ()
VLeft e -> do
lift $ $(logError)
[i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
addError

54
app/ghcup/Main.hs
View File

@ -16,6 +16,7 @@ import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
@ -25,15 +26,16 @@ import Data.Char
import Data.List ( intercalate ) import Data.List ( intercalate )
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import Data.String.Interpolate import Data.String.Interpolate
import Data.String.QQ
import Data.Versions import Data.Versions
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import HPath import HPath
import HPath.IO
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Console.Pretty import System.Console.Pretty
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.IO import System.IO hiding ( appendFile )
import Text.Read import Text.Read
import Text.Layout.Table import Text.Layout.Table
import URI.ByteString import URI.ByteString
@ -120,13 +122,15 @@ opts =
(option (option
(eitherReader parseUri) (eitherReader parseUri)
(short 's' <> long "url-source" <> metavar "URL" <> help (short 's' <> long "url-source" <> metavar "URL" <> help
"Alternative ghcup download info url (default: internal)" "Alternative ghcup download info url"
) )
) )
) )
<*> switch <*> switch
(short 'n' <> long "no-verify" <> help ( short 'n'
"Don't verify sha256 checksums of downloaded tarballs (default: False)" <> long "no-verify"
<> help
"Skip tarball checksum checks (default: False)"
) )
<*> com <*> com
where where
@ -153,7 +157,10 @@ com =
<> command <> command
"upgrade" "upgrade"
( Upgrade ( Upgrade
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")) <$> (info
(upgradeOptsP <**> helper)
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
)
) )
<> commandGroup "Main commands:" <> commandGroup "Main commands:"
) )
@ -362,10 +369,15 @@ main = do
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
let settings = toSettings opt let settings = toSettings opt
-- logger interpreter -- logger interpreter
let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr) logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
let runLogger = myLoggerT LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
-- wrapper to run effects with settings -- wrapper to run effects with settings
let runInstTool = let runInstTool =
@ -463,8 +475,11 @@ main = do
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
VLeft e -> VLeft e -> do
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
Install (InstallCabal InstallOptions {..}) -> Install (InstallCabal InstallOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
@ -478,8 +493,11 @@ main = do
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
VLeft e -> VLeft e -> do
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
SetGHC (SetGHCOptions {..}) -> SetGHC (SetGHCOptions {..}) ->
void void
@ -550,8 +568,8 @@ main = do
pure $ Just p pure $ Just p
(UpgradeAt p) -> pure $ Just p (UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do UpgradeGHCupDir -> do
liftIO $ putStrLn "blah" bdir <- liftIO $ ghcupBinDir
pure Nothing pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
void void
$ (runUpgrade $ do $ (runUpgrade $ do
@ -559,9 +577,11 @@ main = do
liftE $ upgradeGHCup dls target liftE $ upgradeGHCup dls target
) )
>>= \case >>= \case
VRight v' -> VRight v' -> do
runLogger $ $(logInfo) let pretty_v = prettyVer v'
[i|Successfully upgraded GHCup to version #{v'}|] runLogger
$ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure

9
ghcup.cabal
View File

@ -58,7 +58,6 @@ 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 }
common string-qq { build-depends: string-qq >= 0.0.4 }
common table-layout { build-depends: table-layout >= 0.8 } common table-layout { build-depends: table-layout >= 0.8 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 } common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
@ -127,7 +126,6 @@ library
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-interpolate , string-interpolate
, string-qq
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
, text , text
@ -150,9 +148,12 @@ library
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Utils GHCup.Utils
GHCup.Utils.Bash GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File GHCup.Utils.File
GHCup.Utils.Logger GHCup.Utils.Logger
GHCup.Utils.Prelude GHCup.Utils.Prelude
GHCup.Utils.String.QQ
GHCup.Utils.Version.QQ
GHCup.Version GHCup.Version
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
@ -171,9 +172,9 @@ executable ghcup
, text , text
, versions , versions
, hpath , hpath
, hpath-io
, pretty-terminal , pretty-terminal
, resourcet , resourcet
, string-qq
, string-interpolate , string-interpolate
, table-layout , table-layout
, uri-bytestring , uri-bytestring
@ -203,7 +204,7 @@ executable ghcup-gen
, versions , versions
, hpath , hpath
, pretty-terminal , pretty-terminal
, string-qq , resourcet
, string-interpolate , string-interpolate
, table-layout , table-layout
, transformers , transformers

28
lib/GHCup.hs
View File

@ -21,7 +21,8 @@ import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Version import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -37,7 +38,6 @@ import Data.Foldable
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.Versions import Data.Versions
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
@ -148,13 +148,19 @@ installGHC :: (MonadLogger m, MonadIO m)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installGHC path inst = do installGHC path inst = do
lift $ $(logInfo) [s|Installing GHC|] lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ exec [s|./configure|] lEM $ liftIO $ execLogged [s|./configure|]
False False
[[s|--prefix=|] <> toFilePath inst] [[s|--prefix=|] <> toFilePath inst]
(Just path) ([rel|ghc-configure.log|] :: Path Rel)
Nothing (Just path)
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure () pure ()
@ -418,12 +424,12 @@ getDebugInfo = do
--------------- ---------------
--[ Compile ]-- --[ Compile ]--
--------------- ---------------
-- TODO: build config
compileGHC :: ( MonadReader Settings m compileGHC :: ( MonadReader Settings m
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
@ -544,7 +550,7 @@ upgradeGHCup dls mtarget = do
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
case mtarget of case mtarget of
Nothing -> do Nothing -> do
dest <- liftIO $ ghcupBinDir dest <- liftIO $ ghcupBinDir

2
lib/GHCup/Download.hs
View File

@ -17,6 +17,7 @@ import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -32,7 +33,6 @@ import Data.ByteString.Builder
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
import Data.String.QQ
import Data.Versions import Data.Versions
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath

2
lib/GHCup/Platform.hs
View File

@ -13,6 +13,7 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.Bash import GHCup.Utils.Bash
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -23,7 +24,6 @@ import Control.Monad.Trans.Class ( lift )
import Data.Foldable import Data.Foldable
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
import Data.String.QQ
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import HPath import HPath

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

@ -12,11 +12,12 @@
module GHCup.Types.JSON where module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Data.Aeson import Data.Aeson
import Data.Aeson.TH import Data.Aeson.TH
import Data.Aeson.Types import Data.Aeson.Types
import Data.String.QQ
import Data.Text.Encoding ( decodeUtf8 ) import Data.Text.Encoding ( decodeUtf8 )
import Data.Text.Encoding as E import Data.Text.Encoding as E
import Data.Versions import Data.Versions
@ -28,20 +29,18 @@ import qualified Data.ByteString as BS
import qualified Data.Text as T import qualified Data.Text as T
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions ''Architecture deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions ''LinuxDistro deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions ''Mess deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions ''Platform deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions ''SemVer deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions ''Tool deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions ''VSep deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions ''VUnit deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions ''Tag deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
deriveJSON defaultOptions ''DownloadInfo
deriveJSON defaultOptions ''GHCupDownloads
instance ToJSON URI where instance ToJSON URI where

134
lib/GHCup/Utils.hs
View File

@ -4,14 +4,20 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils where module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -25,7 +31,6 @@ import Data.ByteString ( ByteString )
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.Versions import Data.Versions
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
@ -38,7 +43,6 @@ import Prelude hiding ( abs
, writeFile , writeFile
) )
import Safe import Safe
import System.Posix.Env.ByteString ( getEnv )
import System.Posix.FilePath ( takeFileName ) import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink ) import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString import URI.ByteString
@ -54,27 +58,11 @@ import qualified Data.Text.Encoding as E
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs) ------------------------
ghcupBaseDir = do --[ Symlink handling ]--
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. -- | The symlink destination of a ghc tool.
@ -95,6 +83,13 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
Right r -> pure r Right r -> pure r
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
ghcInstalled :: Version -> IO Bool ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
@ -110,11 +105,6 @@ ghcSet = do
link <- readSymbolicLink $ toFilePath ghcBin link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link 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 :: Version -> IO Bool
cabalInstalled ver = do cabalInstalled ver = do
@ -132,6 +122,13 @@ cabalSet = do
Left e -> throwM e Left e -> throwM e
Right r -> pure r Right r -> pure r
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
-- | We assume GHC is in semver format. I hope it is. -- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m (Int, Int) getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do getGHCMajor ver = do
@ -160,10 +157,12 @@ getGHCForMajor major' minor' = do
$ semvers $ semvers
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel) -----------------
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False --[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path. -- | Unpack an archive to a temporary directory and return that path.
@ -191,6 +190,55 @@ unpackToDir dest av = do
| otherwise -> throwE $ UnknownArchive fn | otherwise -> throwE $ UnknownArchive fn
------------
--[ Tags ]--
------------
-- | 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
-----------------------
--[ Settings Getter ]--
-----------------------
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* -- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks. -- while ignoring *-<ver> symlinks.
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
@ -214,27 +262,3 @@ ghcToolFiles ver = do
when (B.null symver) when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken") (throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files 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

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

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

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

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

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

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

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

@ -1,15 +1,10 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module GHCup.Utils.Prelude where module GHCup.Utils.Prelude where
@ -21,20 +16,12 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Data
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String import Data.String
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import GHC.Base
import Haskus.Utils.Types.List import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import System.IO.Error import System.IO.Error
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -45,7 +32,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy.Encoding as TLE
import qualified Language.Haskell.TH.Syntax as TH
@ -197,84 +183,20 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action 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
Left e -> throwM e Left e -> throwM e
Right r -> pure r Right r -> pure r
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
verToBS :: Version -> ByteString verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

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

@ -0,0 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
-- The "s" quoter contains a multi-line string with no interpolation at all,
-- except that the leading newline is trimmed and carriage returns stripped.
--
-- @
-- {-\# LANGUAGE QuasiQuotes #-}
-- import Data.Text (Text)
-- import Data.String.QQ
-- foo :: Text -- "String", "ByteString" etc also works
-- foo = [s|
-- Well here is a
-- multi-line string!
-- |]
-- @
--
-- Any instance of the IsString type is permitted.
--
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
--
module GHCup.Utils.String.QQ
( s
)
where
import Data.Char
import GHC.Exts ( IsString(..) )
import Language.Haskell.TH.Quote
-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
-- The pattern portion is undefined.
s :: QuasiQuoter
s = QuasiQuoter
(\s' -> case and $ fmap isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

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

@ -0,0 +1,89 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.Version.QQ where
import Data.Data
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

3
lib/GHCup/Version.hs
View File

@ -3,8 +3,9 @@
module GHCup.Version where module GHCup.Version where
import GHCup.Utils.Version.QQ
import Data.Versions import Data.Versions
import GHCup.Utils.Prelude
ghcUpVer :: PVP ghcUpVer :: PVP
ghcUpVer = [pver|0.1.0|] ghcUpVer = [pver|0.1.0|]