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

Initial commit

Browse Source
This commit is contained in:
Julian Ospald 2020-01-11 21:15:05 +01:00
commit a93aaf9a5f
30 changed files with 6617 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
dist-newstyle/

5
CHANGELOG.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for ghcup
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

165
LICENSE Normal file
View File

@ -0,0 +1,165 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

37
README.md Normal file
View File

@ -0,0 +1,37 @@
# ghcup
A rewrite of ghcup in haskell.
## TODO
* create static ghcup binaries
* adjust url in GHCupDownloads
* add print-system-reqs command
## Motivation
Maintenance problems:
* platform incompatibilities regularly causing breaking bugs:
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
* refactoring being difficult due to POSIX sh
Benefits of a rewrite:
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
* Refactoring will be easier
* Better tool support (such as linting the downloads file)
* saner downloads file format (such as JSON)
Downsides:
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
* still bootstrapping those binaries via a POSIX sh script
## Goals
* Correct low-level code
* Good exception handling
* Cleaner user interface

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

1693
app/ghcup-gen/GHCupDownloads.hs Normal file
View File

File diff suppressed because it is too large Load Diff

164
app/ghcup-gen/Main.hs Normal file
View File

@ -0,0 +1,164 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import GHCupDownloads
import Data.Aeson ( eitherDecode )
import Data.Aeson.Encode.Pretty
import Data.Semigroup ( (<>) )
import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import Validate
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
data Options = Options
{ optCommand :: Command
}
data Command = GenJSON GenJSONOpts
| ValidateJSON ValidateJSONOpts
| ValidateTarballs ValidateJSONOpts
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdOutput
fileOutput :: Parser Output
fileOutput =
FileOutput
<$> (strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Output to a file"
)
)
stdOutput :: Parser Output
stdOutput = flag'
StdOutput
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
outputP :: Parser Output
outputP = fileOutput <|> stdOutput
data GenJSONOpts = GenJSONOpts
{ output :: Maybe Output
}
genJSONOpts :: Parser GenJSONOpts
genJSONOpts = GenJSONOpts <$> optional outputP
data Input
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdInput
fileInput :: Parser Input
fileInput =
FileInput
<$> (strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
)
stdInput :: Parser Input
stdInput = flag'
StdInput
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateJSONOpts = ValidateJSONOpts
{ input :: Maybe Input
}
validateJSONOpts :: Parser ValidateJSONOpts
validateJSONOpts = ValidateJSONOpts <$> optional inputP
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
( (command
"gen"
( GenJSON
<$> (info (genJSONOpts <**> helper)
(progDesc "Generate the json downloads file")
)
)
)
<> (command
"check"
( ValidateJSON
<$> (info (validateJSONOpts <**> helper)
(progDesc "Validate the JSON")
)
)
)
<> (command
"check-tarballs"
( ValidateTarballs
<$> (info
(validateJSONOpts <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
)
)
main :: IO ()
main = do
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
GenJSON gopts -> do
let
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
ghcupDownloads
case gopts of
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
GenJSONOpts { output = Just (FileOutput file) } ->
L.writeFile file bs
ValidateJSON vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just (FileInput file) } ->
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 ()
where
valAndExit f contents = do
av <- case eitherDecode contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith

181
app/ghcup-gen/Validate.hs Normal file
View File

@ -0,0 +1,181 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
module Validate where
import GHCup
import GHCup.Download
import GHCup.Types
import GHCup.Utils.Logger
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Optics
import System.Exit
import System.IO
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> m ExitCode
validate dls = do
ref <- liftIO $ newIORef 0
-- * verify binary downloads * --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs)
checkGHCisSemver
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
checkHasRequiredPlatforms t v arch pspecs = do
let v' = prettyVer v
when (not $ any (== Linux UnknownLinux) pspecs) $ do
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
addError
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
addError
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
<$> ( mapM
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
)
. group
. sort
$ allTags
)
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
checkGHCisSemver = do
let ghcVers = toListOf (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 ()
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ fmap snd $ availableToolVersions dls tool
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
, MonadMask m
)
=> GHCupDownloads
-> m ExitCode
validateTarballs dls = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all binary tarballs
let
dlbis = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs ->
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
forM_ dlbis $ downloadAll
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
forM_ dlsrc $ 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

702
app/ghcup/Main.hs Normal file
View File

@ -0,0 +1,702 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Char
import Data.List ( intercalate )
import Data.Semigroup ( (<>) )
import Data.String.Interpolate
import Data.Versions
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.Read
import Text.Layout.Table
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
data Options = Options
{
-- global options
optVerbose :: Bool
, optCache :: Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Bool
-- commands
, optCommand :: Command
}
data Command
= Install InstallCommand
| SetGHC SetGHCOptions
| List ListOptions
| Rm RmOptions
| DInfo
| Compile CompileCommand
| Upgrade UpgradeOpts
| NumericVersion
data ToolVersion = ToolVersion Version
| ToolTag Tag
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
}
data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe ToolVersion
}
data ListOptions = ListOptions
{ lTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
}
data RmOptions = RmOptions
{ ghcVer :: Version
}
data CompileCommand = CompileGHC CompileOptions
| CompileCabal CompileOptions
data CompileOptions = CompileOptions
{ targetVer :: Version
, bootstrapVer :: Version
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
deriving Show
opts :: Parser Options
opts =
Options
<$> switch
(short 'v' <> long "verbose" <> help
"Whether to enable verbosity (default: False)"
)
<*> switch
(short 'c' <> long "cache" <> help
"Whether to cache downloads (default: False)"
)
<*> (optional
(option
(eitherReader parseUri)
(short 's' <> long "url-source" <> metavar "URL" <> help
"Alternative ghcup download info url" <> internal
)
)
)
<*> switch
(short 'n' <> long "no-verify" <> help
"Skip tarball checksum verification (default: False)"
)
<*> com
where
parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
com =
subparser
( command
"install"
( Install
<$> (info (installP <**> helper)
(progDesc "Install or update GHC/cabal")
)
)
<> command
"list"
( List
<$> (info (listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
)
<> command
"upgrade"
( Upgrade
<$> (info
(upgradeOptsP <**> helper)
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
)
)
<> command
"compile"
( Compile
<$> (info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
)
<> commandGroup "Main commands:"
)
<|> subparser
( command
"set"
( SetGHC
<$> (info (setGHCOpts <**> helper)
(progDesc "Set the currently active GHC version")
)
)
<> command
"rm"
( Rm
<$> (info
(rmOpts <**> helper)
(progDesc "Remove a GHC version installed by ghcup")
)
)
<> commandGroup "GHC commands:"
<> hidden
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
<> command
"numeric-version"
( (\_ -> NumericVersion)
<$> (info (helper) (progDesc "Show the numeric version"))
)
<> commandGroup "Other commands:"
<> hidden
)
installP :: Parser InstallCommand
installP = subparser
( command
"ghc"
( InstallGHC
<$> (info (installOpts <**> helper) (progDesc "Install a GHC version"))
)
<> command
"cabal"
( InstallCabal
<$> (info (installOpts <**> helper)
(progDesc "Install or update a Cabal version")
)
)
)
installOpts :: Parser InstallOptions
installOpts = InstallOptions <$> optional toolVersionParser
setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
listOpts :: Parser ListOptions
listOpts =
ListOptions
<$> optional
(option
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
"Tool to list versions for. Default is all"
)
)
<*> (optional
(option
(eitherReader criteriaParser)
( short 'c'
<> long "show-criteria"
<> metavar "<installed|set>"
<> help "Show only installed or set tool versions"
)
)
)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionParser
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
)
)
<> command
"cabal"
( CompileCabal
<$> (info (compileOpts <**> helper)
(progDesc "Compile Cabal from source")
)
)
)
compileOpts :: Parser CompileOptions
compileOpts =
CompileOptions
<$> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool 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 = option
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP <|> toolP
where
verP = ToolVersion <$> versionParser
toolP =
ToolTag
<$> (option
(eitherReader
(\s' -> case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
other -> Left ([i|Unknown tag #{other}|])
)
)
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
)
toolParser :: String -> Either String Tool
toolParser s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
toSettings :: Options -> Settings
toSettings Options {..} =
let cache = optCache
urlSource = maybe GHCupURL OwnSource optUrlSource
noVerify = optNoVerify
in Settings { .. }
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> (option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
)
<|> (pure UpgradeGHCupDir)
main :: IO ()
main = do
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- logger interpreter
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
let runInstTool =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, UnknownArchive
, DistroNotFound
, FileDoesNotExistError
, CopyError
, JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
]
let runSetGHC =
runLogger
. flip runReaderT settings
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, JSONError
, TagNotFound
, DownloadFailed
]
let runListGHC =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. flip runReaderT settings
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DownloadFailed
, GHCupSetError
, NoDownload
, UnknownArchive
--
, JSONError
]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ JSONError
, UnknownArchive
, NoDownload
, DigestError
, DownloadFailed
, BuildFailed
]
let runUpgrade =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, FileDoesNotExistError
, JSONError
, DownloadFailed
, CopyError
]
case optCommand of
Install (InstallGHC InstallOptions {..}) ->
void
$ (runInstTool $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls v Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
Install (InstallCabal InstallOptions {..}) ->
void
$ (runInstTool $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls v Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
SetGHC (SetGHCOptions {..}) ->
void
$ (runSetGHC $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls ghcVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight _ ->
runLogger $ $(logInfo) ([s|GHC successfully set|])
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
List (ListOptions {..}) ->
void
$ (runListGHC $ do
dls <- liftE getDownloads
liftIO $ listVersions dls lTool lCriteria
)
>>= \case
VRight r -> liftIO $ printListResult r
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Rm (RmOptions {..}) ->
void
$ (runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ()
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
DInfo -> do
void
$ (runDebugInfo $ do
liftE $ getDebugInfo
)
>>= \case
VRight dinfo -> putStrLn $ show dinfo
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileGHC CompileOptions {..}) ->
void
$ (runCompileGHC $ do
dls <- liftE getDownloads
liftE
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|GHC successfully compiled and installed|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileCabal CompileOptions {..}) ->
void
$ (runCompileCabal $ do
dls <- liftE getDownloads
liftE $ compileCabal dls
targetVer
bootstrapVer
jobs
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|Cabal successfully compiled and installed|])
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Upgrade (uOpts) -> do
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO $ getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
void
$ (runUpgrade $ do
dls <- liftE getDownloads
liftE $ upgradeGHCup dls target
)
>>= \case
VRight v' -> do
let pretty_v = prettyVer v'
runLogger
$ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
pure ()
fromVersion :: Monad m
=> GHCupDownloads
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound] m Version
fromVersion av Nothing tool =
getRecommended av tool ?? TagNotFound Recommended tool
fromVersion _ (Just (ToolVersion v)) _ = pure v
fromVersion av (Just (ToolTag Latest)) tool =
getLatest av tool ?? TagNotFound Latest tool
fromVersion av (Just (ToolTag Recommended)) tool =
getRecommended av tool ?? TagNotFound Recommended tool
printListResult :: [ListResult] -> IO ()
printListResult lr = do
let
formatted =
gridString
[ column expand left def def
, column expand left def def
, column expand left def def
, column expand left def def
, column expand left def def
]
$ fmap
(\ListResult {..} ->
[ if
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "✓")
| otherwise -> (color Red "✗")
, fmap toLower . show $ lTool
, T.unpack . prettyVer $ lVer
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
, if fromSrc then (color Blue "compiled") else mempty
]
)
lr
putStrLn $ formatted

15
cabal.project Normal file
View File

@ -0,0 +1,15 @@
packages: ./ghcup.cabal
with-compiler: ghc-8.6.5
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package tar-bytestring
ghc-options: -O2

229
cabal.project.freeze Normal file
View File

@ -0,0 +1,229 @@
constraints: any.Cabal ==2.4.0.1,
any.HsOpenSSL ==0.11.4.17,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
any.IfElse ==0.85,
any.QuickCheck ==2.13.2,
QuickCheck +templatehaskell,
any.StateVar ==1.2,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.aeson ==1.4.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
any.ansi-terminal ==0.10.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.3.0,
any.ascii-string ==1.0.1.4,
any.assoc ==1.0.1,
any.async ==2.2.2,
async -bench,
any.atomic-primops ==0.8.3,
atomic-primops -debug,
any.attoparsec ==0.13.2.3,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.12.0.0,
any.base-compat ==0.11.1,
any.base-orphans ==0.8.2,
any.base-prelude ==1.3,
any.base16-bytestring ==0.1.1.6,
any.base64-bytestring ==1.0.0.3,
any.bifunctors ==5.5.7,
bifunctors +semigroups +tagged,
any.binary ==0.8.6.0,
any.blaze-builder ==0.4.1.0,
any.brotli ==0.0.0.0,
any.brotli-streams ==0.0.0.0,
any.bytestring ==0.10.8.2,
any.bytestring-builder ==0.10.8.2.0,
bytestring-builder +bytestring_has_builder,
any.bzlib ==0.5.0.5,
any.cabal-doctest ==1.0.8,
any.case-insensitive ==1.2.1.0,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.clock ==0.8,
clock -llvm,
any.cmdargs ==0.10.20,
cmdargs +quotation -testprog,
any.colour ==2.3.5,
any.comonad ==5.0.6,
comonad +containers +distributive +test-doctests,
any.conduit ==1.3.1.2,
any.conduit-extra ==1.3.4,
any.containers ==0.6.0.1,
any.contravariant ==1.5.2,
contravariant +semigroups +statevar +tagged,
any.data-default-class ==0.1.2.0,
any.data-default-instances-base ==0.1.0.1,
any.deepseq ==1.4.4.0,
any.deferred-folds ==0.9.10.1,
any.directory ==1.3.3.0 || ==1.3.6.0,
any.distributive ==0.6.1,
distributive +semigroups +tagged,
any.dlist ==0.8.0.7,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
exceptions +transformers-0-4,
any.extra ==1.7,
any.fast-logger ==3.0.1,
any.filepath ==1.4.2.1,
any.focus ==1.0.1.3,
any.foldl ==1.4.6,
any.free ==5.1.3,
any.fusion-plugin-types ==0.1.0,
any.generics-sop ==0.5.0.0,
any.ghc-boot-th ==8.6.5,
any.ghc-prim ==0.5.3,
any.happy ==1.19.12,
happy +small_base,
any.hashable ==1.3.0.0,
hashable -examples +integer-gmp +sse2 -sse41,
any.haskell-src-exts ==1.23.0,
any.haskell-src-meta ==0.8.5,
any.haskus-utils-data ==1.2,
any.haskus-utils-types ==1.5,
any.haskus-utils-variant ==3.0,
any.heaps ==0.3.6.1,
any.hopenssl ==2.2.4,
hopenssl -link-libz,
any.hpath ==0.11.0,
any.hpath-directory ==0.13.2,
any.hpath-filepath ==0.10.4,
any.hpath-io ==0.13.1,
any.hpath-posix ==0.13.1,
any.hsc2hs ==0.68.6,
hsc2hs -in-ghc-tree,
any.http-io-streams ==0.1.2.0,
http-io-streams +brotli,
any.indexed-profunctors ==0.1,
any.integer-gmp ==1.0.2.0,
any.integer-logarithms ==1.0.3,
integer-logarithms -check-bounds +integer-gmp,
any.io-streams ==1.5.1.0,
io-streams -nointeractivetests,
any.language-bash ==0.9.0,
any.lifted-base ==0.2.3.12,
any.list-t ==1.0.4,
any.lockfree-queue ==0.2.3.1,
any.lzma ==0.0.0.3,
any.math-functions ==0.3.3.0,
math-functions +system-erf +system-expm1,
any.megaparsec ==8.0.0,
megaparsec -dev,
any.mmorph ==1.1.3,
any.monad-control ==1.0.2.3,
any.monad-logger ==0.3.32,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.mwc-random ==0.14.0.0,
any.network ==3.1.1.1,
any.network-uri ==2.6.3.0,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.2.0,
any.optics ==0.2,
any.optics-core ==0.2,
any.optics-extra ==0.2,
any.optics-th ==0.2,
any.optics-vl ==0.2,
any.optparse-applicative ==0.15.1.0,
any.parsec ==3.1.13.0,
any.parser-combinators ==1.2.1,
parser-combinators -dev,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.prettyprinter ==1.6.1,
prettyprinter -buildreadme,
any.primitive ==0.7.0.1,
any.primitive-extras ==0.8,
any.primitive-unlifted ==0.1.3.0,
any.process ==1.6.5.0 || ==1.6.8.0,
any.profunctors ==5.5.2,
any.random ==1.1,
any.recursion-schemes ==5.1.3,
recursion-schemes +template-haskell,
any.resourcet ==1.2.3,
any.rts ==1.0,
any.safe ==0.3.18,
any.safe-exceptions ==0.1.7.0,
any.scientific ==0.3.6.2,
scientific -bytestring-builder -integer-simple,
any.semigroupoids ==5.3.4,
semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
any.semigroups ==0.19.1,
semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
any.sop-core ==0.5.0.0,
any.split ==0.2.3.4,
any.splitmix ==0.0.4,
splitmix -optimised-mixer +random,
any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.1.2,
streaming-commons -use-bytestring-builder,
any.streamly ==0.7.1,
streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
any.streamly-bytestring ==0.1.2,
any.streamly-posix ==0.1.0.0,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.2.0.0,
any.syb ==0.7.1,
any.table-layout ==0.8.0.5,
any.tagged ==0.8.6,
tagged +deepseq +transformers,
any.tar-bytestring ==0.6.3.0,
any.template-haskell ==2.14.0.0,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.text ==1.2.3.1,
any.text-conversions ==0.3.0,
any.text-icu ==0.7.0.1,
any.text-short ==0.1.3,
text-short -asserts,
any.th-abstraction ==0.3.2.0,
any.th-expand-syns ==0.4.5.0,
any.th-lift ==0.8.1,
any.th-lift-instances ==0.1.14,
any.th-orphans ==0.13.9,
any.th-reify-many ==0.1.9,
any.these ==1.0.1,
these +aeson +assoc +quickcheck +semigroupoids,
any.time ==1.8.0.2 || ==1.9.3,
any.time-compat ==1.9.2.2,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
transformers-base +orphaninstances,
any.transformers-compat ==0.6.5,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.2,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.10.0,
unordered-containers -debug,
any.uri-bytestring ==0.3.2.2,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.1.1,
any.uuid-types ==1.0.3,
any.vector ==0.12.1.2,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.3,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.vector-builder ==0.3.8,
any.vector-th-unbox ==0.2.1.7,
any.versions ==3.5.3,
any.word8 ==0.1.3,
any.zlib ==0.6.2.1,
zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5

234
ghcup.cabal Normal file
View File

@ -0,0 +1,234 @@
cabal-version: 2.2
name: ghcup
version: 0.1.0.0
synopsis: ghc toolchain installer as an exe/library
description: A rewrite of the shell script ghcup, for providing
a more stable user experience and exposing an API.
homepage: https://github.com/hasufell/ghcup-hs
bug-reports: https://github.com/hasufell/ghcup-hs/issues
license: LGPL-3.0-only
license-file: LICENSE
author: Julian Ospald
maintainer: hasufell@posteo.de
copyright: Julian Ospald 2020
category: System
build-type: Simple
extra-source-files: CHANGELOG.md
source-repository head
type: git
location: https://github.com/hasufell/ghcup-hs
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
common aeson { build-depends: aeson >= 1.4 }
common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
common ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 }
common attoparsec { build-depends: attoparsec >= 0.13 }
common base { build-depends: base >= 4.12 && < 5 }
common binary { build-depends: binary >= 0.8.6.0 }
common bytestring { build-depends: bytestring >= 0.10 }
common bzlib { build-depends: bzlib >= 0.5.0.5 }
common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 }
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
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-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
common hpath-io { build-depends: hpath-io >= 0.13.1 }
common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
common io-streams { build-depends: io-streams >= 1.5 }
common language-bash { build-depends: language-bash >= 0.9 }
common lzma { build-depends: lzma >= 0.0.0.3 }
common monad-logger { build-depends: monad-logger >= 0.3.31 }
common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 }
common optics-vl { build-depends: optics-vl >= 0.2 }
common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
common parsec { build-depends: parsec >= 3.1 }
common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
common resourcet { build-depends: resourcet >= 1.2.2 }
common safe { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7.1 }
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 }
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
common table-layout { build-depends: table-layout >= 0.8 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
common template-haskell { build-depends: template-haskell >= 2.7 }
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 }
common time { build-depends: time >= 1.9.3 }
common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 }
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
common uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 }
common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common word8 { build-depends: word8 >= 0.1.3 }
common zlib { build-depends: zlib >= 0.6.2.1 }
common config
default-language: Haskell2010
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
default-extensions: LambdaCase
, MultiWayIf
, PackageImports
, RecordWildCards
, ScopedTypeVariables
, StrictData
, Strict
, TupleSections
library
import: config
, base
-- deps
, HsOpenSSL
, aeson
, ascii-string
, async
, attoparsec
, binary
, bytestring
, bzlib
, case-insensitive
, containers
, generics-sop
, haskus-utils-types
, haskus-utils-variant
, hopenssl
, hpath
, hpath-directory
, hpath-filepath
, hpath-io
, hpath-posix
, http-io-streams
, io-streams
, language-bash
, lzma
, monad-logger
, mtl
, optics
, optics-vl
, parsec
, pretty-terminal
, resourcet
, safe
, safe-exceptions
, streamly
, streamly-posix
, streamly-bytestring
, strict-base
, string-interpolate
, tar-bytestring
, template-haskell
, terminal-progress-bar
, text
, text-icu
, time
, transformers
, unix
, unix-bytestring
, uri-bytestring
, utf8-string
, vector
, versions
, word8
, zlib
exposed-modules: GHCup
GHCup.Download
GHCup.Errors
GHCup.Platform
GHCup.Types
GHCup.Types.JSON
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.Logger
GHCup.Utils.Prelude
GHCup.Utils.String.QQ
GHCup.Utils.Version.QQ
GHCup.Version
-- other-modules:
-- other-extensions:
hs-source-dirs: lib
executable ghcup
import: config
, base
--
, bytestring
, containers
, haskus-utils-variant
, monad-logger
, mtl
, optparse-applicative
, text
, versions
, hpath
, hpath-io
, pretty-terminal
, resourcet
, string-interpolate
, table-layout
, uri-bytestring
, utf8-string
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app/ghcup
default-language: Haskell2010
executable ghcup-gen
import: config
, base
--
, aeson
, aeson-pretty
, bytestring
, containers
, safe-exceptions
, haskus-utils-variant
, monad-logger
, mtl
, optics
, optparse-applicative
, text
, versions
, hpath
, pretty-terminal
, resourcet
, string-interpolate
, table-layout
, transformers
, uri-bytestring
, utf8-string
main-is: Main.hs
other-modules: GHCupDownloads
Validate
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app/ghcup-gen
default-language: Haskell2010
test-suite ghcup-test
default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: MyLibTest.hs
build-depends: base ^>=4.12.0.0

686
lib/GHCup.hs Normal file
View File

@ -0,0 +1,686 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
module GHCup where
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import GHCup.Version
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.IO.Error
import System.Posix.FilePath ( getSearchPath )
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import qualified Data.ByteString as B
import qualified Data.Map.Strict as Map
import qualified Data.Text.Encoding as E
-------------------------
--[ Tool installation ]--
-------------------------
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installGHCBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ toolAlreadyInstalled GHC ver)
$ (throwE $ AlreadyInstalled GHC ver)
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
-- prepare paths
ghcdir <- liftIO $ ghcupGHCDir ver
-- the subdir of the archive where we do the work
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
catchAllE
(\es ->
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
>> throwE (BuildFailed archiveSubdir es)
)
$ installGHC' archiveSubdir ghcdir
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
liftE $ postGHCInstall ver
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
([rel|ghc-configure.log|] :: Path Rel)
(Just path)
Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure ()
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, UnknownArchive
]
m
()
installCabalBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
-- prepare paths
bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
liftE $ installCabal' archiveSubdir bindir
pure ()
where
-- | Install an unpacked cabal distribution.
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) [s|Installing cabal|]
let cabalFile = [rel|cabal|] :: Path Rel
liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> cabalFile)
Overwrite
---------------
--[ Set GHC ]--
---------------
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> SetGHC
-> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
let verBS = verToBS ver
ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
SetGHCOnly -> liftE $ rmPlain ver
SetGHC_XY -> lift $ rmMajorSymlinks ver
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHC_XY -> do
major' <-
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
<$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-- create symlink
let fullF = bindir </> targetFile
let destL = ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir
lift $ symlinkShareDir ghcdir verBS
pure ()
where
symlinkShareDir :: (MonadIO m, MonadLogger m)
=> Path Abs
-> ByteString
-> m ()
symlinkShareDir ghcdir verBS = do
destdir <- liftIO $ ghcupBaseDir
case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
$(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO $ createSymlink fullF targetF
_ -> pure ()
------------------
--[ List tools ]--
------------------
data ListCriteria = ListInstalled
| ListSet
deriving Show
data ListResult = ListResult
{ lTool :: Tool
, lVer :: Version
, lTag :: [Tag]
, lInstalled :: Bool
, lSet :: Bool
, fromSrc :: Bool
}
deriving Show
availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
av
listVersions :: GHCupDownloads
-> Maybe Tool
-> Maybe ListCriteria
-> IO [ListResult]
listVersions av lt criteria = case lt of
Just t -> do
filter' <$> forM (availableToolVersions av t) (toListResult t)
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria
ghcupvers <- listVersions av (Just GHCup) criteria
pure (ghcvers <> cabalvers <> ghcupvers)
where
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult t (v, tags) = case t of
GHC -> do
lSet <- fmap (maybe False (== v)) $ ghcSet
lInstalled <- ghcInstalled v
fromSrc <- ghcSrcInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
Cabal -> do
lSet <- fmap (== v) $ cabalSet
lInstalled <- cabalInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = True
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of
Nothing -> lr
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
Just ListSet -> filter (\ListResult {..} -> lSet) lr
--------------
--[ GHC rm ]--
--------------
-- | This function may throw and crash in various ways.
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir
if exists
then do
-- this isn't atomic, order matters
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
(mj, mi) <- getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain ver
liftIO
$ ghcupBaseDir
>>= hideError doesNotExistErrorType
. deleteFile
. (</> ([rel|share|] :: Path Rel))
else throwE (NotInstalled GHC ver)
------------------
--[ Debug info ]--
------------------
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m
DebugInfo
getDebugInfo = do
diBaseDir <- liftIO $ ghcupBaseDir
diBinDir <- liftIO $ ghcupBinDir
diGHCDir <- liftIO $ ghcupGHCBaseDir
diCacheDir <- liftIO $ ghcupCacheDir
diURLSource <- lift $ getUrlSource
diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform
pure $ DebugInfo { .. }
---------------
--[ Compile ]--
---------------
compileGHC :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadResource m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Version -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DownloadFailed
, GHCupSetError
, NoDownload
, UnknownArchive
]
m
()
compileGHC dls tver bver jobs mbuildConfig = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
whenM (liftIO $ toolAlreadyInstalled GHC tver)
(throwE $ AlreadyInstalled GHC tver)
-- download source tarball
dlInfo <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
catchAllE
(\es ->
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
>> throwE (BuildFailed workdir es)
)
$ compile bghc ghcdir workdir
markSrcBuilt ghcdir workdir
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
reThrowAll GHCupSetError $ postGHCInstall tver
pure ()
where
defaultConf = [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES
GhcWithLlvmCodeGen = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
=> Path Rel
-> Path Abs
-> Path Abs
-> Excepts
'[NoDownload , FileDoesNotExistError , ProcessError]
m
()
compile bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|]
if
| tver >= [vver|8.8.0|] -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
newEnv <- addToCurrentEnv [([s|GHC|], toFilePath bghcPath)]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath ghcdir]
([rel|ghc-configure.log|] :: Path Rel)
(Just workdir)
(Just newEnv)
| otherwise -> do
lEM $ liftIO $ execLogged
[s|./configure|]
False
[ [s|--prefix=|] <> toFilePath ghcdir
, [s|--with-ghc=|] <> toFilePath bghc
]
([rel|ghc-configure.log|] :: Path Rel)
(Just workdir)
Nothing
case mbuildConfig of
Just bc -> liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
Nothing ->
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
lEM $ liftIO $ execLogged [s|make|]
True
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
([rel|ghc-make.log|] :: Path Rel)
(Just workdir)
Nothing
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just workdir)
Nothing
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ copyFile (build_mk workdir) dest Overwrite
build_mk workdir = workdir </> ([rel|mk/build.mk|] :: Path Rel)
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
, MonadLogger m
, MonadIO m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Version -- ^ GHC version to build with
-> Maybe Int
-> Excepts
'[ BuildFailed
, DigestError
, DownloadFailed
, NoDownload
, UnknownArchive
]
m
()
compileCabal dls tver bver jobs = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
reThrowAll (BuildFailed workdir) $ compile workdir
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
pure ()
where
compile :: (MonadLogger m, MonadIO m)
=> Path Abs
-> Excepts '[ProcessError] m ()
compile workdir = do
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
let v' = verToBS bver
cabal_bin <- liftIO $ ghcupBinDir
newEnv <- lift $ addToCurrentEnv
[ ([s|GHC|] , [s|ghc-|] <> v')
, ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
, ([s|GHC_VER|], v')
, ([s|PREFIX|] , toFilePath cabal_bin)
]
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
False
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
([rel|cabal-bootstrap.log|] :: Path Rel)
(Just workdir)
(Just newEnv)
---------------------
--[ Upgrade GHCup ]--
---------------------
upgradeGHCup :: ( MonadMask m
, MonadReader Settings m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
]
m
Version
upgradeGHCup dls mtarget = do
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = head $ getTagged dls GHCup Latest
dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn)
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
(dest </> fn)
Overwrite
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
pure latestVer
-------------
--[ Other ]--
-------------
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
postGHCInstall ver = do
liftE $ setGHC ver SetGHC_XYZ
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
(mj, mi) <- liftIO $ getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

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

@ -0,0 +1,615 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Download where
import GHCup.Errors
import GHCup.Platform
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.ByteString ( ByteString )
import Data.ByteString.Builder
import Data.CaseInsensitive ( CI )
import Data.IORef
import Data.Maybe
import Data.String.Interpolate
import Data.Text.Read
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import Data.Versions
import GHC.IO.Exception
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL )
import OpenSSL.Digest
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.IO.Error
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import System.ProgressBar
import URI.ByteString
import URI.ByteString.QQ
import qualified Data.Binary.Builder as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.IO.Streams as Streams
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
------------------
--[ High-level ]--
------------------
-- | Downloads the download information! But only if we need to ;P
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
)
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
getDownloads = do
urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ dl ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ dl url
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
where
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it.
--
-- If not, then send a HEAD request and check for modification time.
-- Only download the file if the modification time is newer
-- than the local file.
--
-- Always save the local file with the mod time of the remote file.
dl :: forall m1
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m1
L.ByteString
dl uri' = do
let path = view pathL' uri'
json_file <- (liftIO $ ghcupCacheDir)
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
e <- liftIO $ doesFileExist json_file
if e
then do
accessTime <-
PF.accessTimeHiRes
<$> (liftIO $ PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO $ getPOSIXTime
-- access time won't work on most linuxes, but we can try regardless
if (currentTime - accessTime) > 300
then do -- no access in last 5 minutes, re-check upstream mod time
getModTime >>= \case
Just modTime -> do
fileMod <- liftIO $ getModificationTime json_file
if modTime > fileMod
then do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
else liftIO $ readFile json_file
Nothing -> do
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
liftIO $ deleteFile json_file
liftE $ downloadBS uri'
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do
getModTime >>= \case
Just modTime -> do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
Nothing -> do
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
liftE $ downloadBS uri'
where
getModTime = do
headers <-
handleIO (\_ -> pure mempty)
$ liftE
$ ( catchAllE
(\_ ->
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
)
$ getHead uri'
)
pure $ parseModifiedHeader headers
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
parseModifiedHeader headers =
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
True
defaultTimeLocale
"%a, %d %b %Y %H:%M:%S %Z"
(T.unpack . E.decodeUtf8 $ h)
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
writeFileWithModTime utctime path content = do
let mod_time = utcTimeToPOSIXSeconds utctime
writeFileL path (Just newFilePerms) content
setModificationTimeHiRes path mod_time
getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
=> GHCupDownloads
-> Tool
-> Version
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
]
m
DownloadInfo
getDownloadInfo bDls t v mpfReq = do
(PlatformRequest arch' plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
lE $ getDownloadInfo' t v arch' plat ver bDls
getDownloadInfo' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
where
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
distro_preview f g =
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
-- 1. try to guess the filename from the url path
-- 2. otherwise create a random file
--
-- The file must not exist.
download :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn
| scheme == [s|https|] = dl
| scheme == [s|http|] = dl
| scheme == [s|file|] = cp
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
cp = do
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
pure destFile
dl = do
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
(https, host, fullPath, port) <- reThrowAll DownloadFailed
$ uriToQuadruple (view dlUri dli)
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
-- download
fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd
flip finally (liftIO $ closeFd fd)
$ reThrowAll DownloadFailed
$ downloadInternal True https host fullPath port stepper
liftE $ checkDigest dli destFile
pure destFile
-- Manage to find a file we can write the body into.
getDestFile :: MonadThrow m => m (Path Abs)
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
path = view (dlUri % pathL') dli
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader Settings m
)
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> do
cachedir <- liftIO $ ghcupCacheDir
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure $ cachfile
| otherwise -> liftE $ download dli cachedir mfn
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn
------------------
--[ Low-level ]--
------------------
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
L.ByteString
downloadBS uri'
| scheme == [s|https|]
= dl True
| scheme == [s|http|]
= dl False
| scheme == [s|file|]
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path)
| otherwise
= throwE UnsupportedScheme
where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
dl https = do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
-- | Load the result of this download into memory at once.
downloadBS' :: MonadIO m
=> Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
(L.ByteString)
downloadBS' https host path port = do
bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
downloadInternal False https host path port stepper
liftIO (readIORef bref <&> toLazyByteString)
downloadInternal :: MonadIO m
=> Bool -- ^ whether to show a progress bar
-> Bool -- ^ https?
-> ByteString -- ^ host
-> ByteString -- ^ path with query
-> Maybe Int -- ^ optional port
-> (ByteString -> IO a) -- ^ the consuming step function
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
()
downloadInternal = go (5 :: Int)
where
go redirs progressBar https host path port consumer = do
r <- liftIO $ withConnection' https host port action
veitherToExcepts r >>= \case
Just r' ->
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
Nothing -> pure ()
where
action c = do
let q = buildRequest1 $ http GET path
sendRequest c q emptyBody
receiveResponse
c
(\r i' -> runE $ do
let scode = getStatusCode r
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
Just r' -> pure $ Just $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
go (redirs - 1) progressBar https' host' fullPath' port' consumer
Left e -> throwE e
downloadStream r i' = do
let size = case getHeader r [s|Content-Length|] of
Just x' -> case decimal $ E.decodeUtf8 x' of
Left _ -> 0
Right (r', _) -> r'
Nothing -> 0
mpb <- if progressBar
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream
(\case
Just bs -> do
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
void $ consumer bs
Nothing -> pure ()
)
liftIO $ Streams.connect i' outStream
getHead :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
(M.Map (CI ByteString) ByteString)
getHead uri' | scheme == [s|https|] = head' True
| scheme == [s|http|] = head' False
| otherwise = throwE UnsupportedScheme
where
scheme = view (uriSchemeL' % schemeBSL') uri'
head' https = do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ headInternal https host' fullPath' port'
headInternal :: MonadIO m
=> Bool -- ^ https?
-> ByteString -- ^ host
-> ByteString -- ^ path with query
-> Maybe Int -- ^ optional port
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, TooManyRedirs
, NoLocationHeader
]
m
(M.Map (CI ByteString) ByteString)
headInternal = go (5 :: Int)
where
go redirs https host path port = do
r <- liftIO $ withConnection' https host port action
veitherToExcepts r >>= \case
Left r' ->
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
Right hs -> pure hs
where
action c = do
let q = buildRequest1 $ http HEAD path
sendRequest c q emptyBody
unsafeReceiveResponse
c
(\r _ -> runE $ do
let scode = getStatusCode r
if
| scode >= 200 && scode < 300 -> do
let headers = getHeaderMap r
pure $ Right $ headers
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
Just r' -> pure $ Left $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
go (redirs - 1) https' host' fullPath' port'
Left e -> throwE e
withConnection' :: Bool
-> ByteString
-> Maybe Int
-> (Connection -> IO a)
-> IO a
withConnection' https host port action = bracket acquire closeConnection action
where
acquire = case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
-- | Extracts from a URI type: (https?, host, path+query, port)
uriToQuadruple :: Monad m
=> URI
-> Excepts
'[UnsupportedScheme]
m
(Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple URI {..} = do
let scheme = view schemeBSL' uriScheme
host <-
preview (_Just % authorityHostL' % hostBSL') uriAuthority
?? UnsupportedScheme
https <- if
| scheme == [s|https|] -> pure True
| scheme == [s|http|] -> pure False
| otherwise -> throwE UnsupportedScheme
let
queryBS =
BS.intercalate [s|&|]
. fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath =
if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
pure (https, host, fullpath, port)
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
=> DownloadInfo
-> Path Abs
-> Excepts '[DigestError] m ()
checkDigest dli file = do
verify <- lift ask <&> (not . noVerify)
when verify $ do
let p' = toFilePath file
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
c <- liftIO $ readFile file
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

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

@ -0,0 +1,124 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
module GHCup.Errors where
import GHCup.Types
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import HPath
------------------------
--[ Low-level errors ]--
------------------------
-- | A compatible platform could not be found.
data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
deriving Show
-- | Unable to find a download for the requested versio/distro.
data NoDownload = NoDownload
deriving Show
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String
deriving Show
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound
deriving Show
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive ByteString
deriving Show
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show
-- | Unable to copy a file.
data CopyError = CopyError String
deriving Show
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool Version
deriving Show
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int
deriving Show
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
deriving instance Show GHCupSetError
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
---------------------------------------------
-- | Parsing failed.
data ParseError = ParseError String
deriving Show
instance Exception ParseError

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

@ -0,0 +1,166 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift )
import Data.Foldable
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Info
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU
--------------------------
--[ Platform detection ]--
--------------------------
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform , DistroNotFound]
m
PlatformResult
getPlatform = do
pfr <- case os of
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
| hasWord name ["debian"] -> Debian
| hasWord name ["ubuntu"] -> Ubuntu
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
| hasWord name ["fedora"] -> Fedora
| hasWord name ["centos"] -> CentOS
| hasWord name ["Red Hat"] -> RedHat
| hasWord name ["alpine"] -> Alpine
| hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
$ t
)
|| y
)
False
(T.pack <$> matches)
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap lBS2sT $ readFile redhat_release
let nameRe n =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (name, verRe)
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
ver <- readFile debian_version
pure (T.pack "debian", Just $ lBS2sT ver)

144
lib/GHCup/Types.hs Normal file
View File

@ -0,0 +1,144 @@
{-# LANGUAGE DeriveGeneric #-}
module GHCup.Types where
import Data.Map.Strict ( Map )
import Data.Text ( Text )
import Data.Versions
import HPath
import URI.ByteString
import qualified GHC.Generics as GHC
---------------------
--[ Download Tree ]--
---------------------
-- | Description of all binary and source downloads. This is a tree
-- of nested maps.
type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map Version VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
-- | An installable tool.
data Tool = GHC
| Cabal
| GHCup
deriving (Eq, GHC.Generic, Ord, Show)
-- | All necessary information of a tool version, including
-- source download and per-architecture downloads.
data VersionInfo = VersionInfo
{ _viTags :: [Tag] -- ^ version specific tag
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, Show)
-- | A tag. These are currently attached to a version of a tool.
data Tag = Latest
| Recommended
deriving (Ord, Eq, Show)
data Architecture = A_64
| A_32
deriving (Eq, GHC.Generic, Ord, Show)
data Platform = Linux LinuxDistro
-- ^ must exit
| Darwin
-- ^ must exit
| FreeBSD
deriving (Eq, GHC.Generic, Ord, Show)
data LinuxDistro = Debian
| Ubuntu
| Mint
| Fedora
| CentOS
| RedHat
| Alpine
| AmazonLinux
-- rolling
| Gentoo
| Exherbo
-- not known
| UnknownLinux
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
-- | An encapsulation of a download. This can be used
-- to download, extract and install a tool.
data DownloadInfo = DownloadInfo
{ _dlUri :: URI
, _dlSubdir :: Maybe (Path Rel)
, _dlHash :: Text
}
deriving (Eq, Show)
--------------
--[ Others ]--
--------------
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupDownloads
deriving Show
data Settings = Settings
{ cache :: Bool
, urlSource :: URLSource
, noVerify :: Bool
}
deriving Show
data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs
, diBinDir :: Path Abs
, diGHCDir :: Path Abs
, diCacheDir :: Path Abs
, diURLSource :: URLSource
, diArch :: Architecture
, diPlatform :: PlatformResult
}
deriving Show
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHC_XY -- ^ ghc-x.y
| SetGHC_XYZ -- ^ ghc-x.y.z
deriving (Eq, Show)
data PlatformResult = PlatformResult
{ _platform :: Platform
, _distroVersion :: Maybe Versioning
}
deriving (Eq, Show)
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
, _rVersion :: Maybe Versioning
}
deriving (Eq, Show)

149
lib/GHCup/Types/JSON.hs Normal file
View File

@ -0,0 +1,149 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
import Data.Text.Encoding ( decodeUtf8 )
import Data.Text.Encoding as E
import Data.Versions
import Data.Word8
import HPath
import URI.ByteString
import qualified Data.ByteString as BS
import qualified Data.Text as T
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
instance ToJSON URI where
toJSON = toJSON . decodeUtf8 . serializeURIRef'
instance FromJSON URI where
parseJSON = withText "URL" $ \t ->
case parseURI strictURIParserOptions (encodeUtf8 t) of
Right x -> pure x
Left e -> fail . show $ e
instance ToJSON Versioning where
toJSON = toJSON . prettyV
instance FromJSON Versioning where
parseJSON = withText "Versioning" $ \t -> case versioning t of
Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
instance ToJSONKey Versioning where
toJSONKey = toJSONKeyText $ \x -> prettyV x
instance FromJSONKey Versioning where
fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
Right x -> pure x
Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
instance ToJSONKey (Maybe Versioning) where
toJSONKey = toJSONKeyText $ \case
Just x -> prettyV x
Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where
just t = case versioning t of
Right x -> pure x
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
instance ToJSONKey Platform where
toJSONKey = toJSONKeyText $ \case
Darwin -> T.pack "Darwin"
FreeBSD -> T.pack "FreeBSD"
Linux d -> T.pack ("Linux_" <> show d)
instance FromJSONKey Platform where
fromJSONKey = FromJSONKeyTextParser $ \t -> if
| T.pack "Darwin" == t -> pure Darwin
| T.pack "FreeBSD" == t -> pure FreeBSD
| T.pack "Linux_" `T.isPrefixOf` t -> case
T.stripPrefix (T.pack "Linux_") t
of
Just dstr ->
case
(decodeStrict (E.encodeUtf8 (T.pack "\"" <> dstr <> T.pack "\"")) :: Maybe
LinuxDistro
)
of
Just d -> pure $ Linux d
Nothing ->
fail
$ "Unexpected failure in decoding LinuxDistro: "
<> show dstr
Nothing -> fail "Unexpected failure in Platform stripPrefix"
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
instance ToJSONKey Architecture where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey Architecture where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON Version where
toJSON = toJSON . prettyVer
instance FromJSON Version where
parseJSON = withText "Version" $ \t -> case version t of
Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
instance ToJSONKey Version where
toJSONKey = toJSONKeyText $ \x -> prettyVer x
instance FromJSONKey Version where
fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
instance ToJSONKey Tool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . E.decodeUtf8 $ fp
False -> String [s|/not/a/valid/path|]
where fp = toFilePath p
instance FromJSON (Path Rel) where
parseJSON = withText "HPath Rel" $ \t -> do
let d = encodeUtf8 t
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e

48
lib/GHCup/Types/Optics.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Types.Optics where
import GHCup.Types
import Data.ByteString ( ByteString )
import Optics
import URI.ByteString
makePrisms ''Tool
makePrisms ''Architecture
makePrisms ''LinuxDistro
makePrisms ''Platform
makePrisms ''Tag
makeLenses ''PlatformResult
makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL
schemeBSL' :: Lens' Scheme ByteString
schemeBSL' = lensVL schemeBSL
authorityL' :: Lens' (URIRef a) (Maybe Authority)
authorityL' = lensVL authorityL
authorityHostL' :: Lens' Authority Host
authorityHostL' = lensVL authorityHostL
authorityPortL' :: Lens' Authority (Maybe Port)
authorityPortL' = lensVL authorityPortL
portNumberL' :: Lens' Port Int
portNumberL' = lensVL portNumberL
hostBSL' :: Lens' Host ByteString
hostBSL' = lensVL hostBSL
pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL

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

@ -0,0 +1,330 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift )
import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString )
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.IO.Error
import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.Map.Strict as Map
import qualified Data.Text.Encoding as E
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> Version
-> ByteString
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
-- | Extract the version part of the result of `ghcLinkDestination`.
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
where
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
verParser = many1' (notWord8 _slash) >>= \t ->
case version $ E.decodeUtf8 $ B.pack t of
Left e -> fail $ show e
Right r -> pure r
-- e.g. ghc-8.6.5
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
rmMinorSymlinks ver = do
bindir <- liftIO $ ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
rmPlain ver = do
files <- liftE $ ghcToolFiles ver
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do
let fullF = (bindir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (bindir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- e.g. ghc-8.6
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
rmMajorSymlinks ver = do
(mj, mi) <- liftIO $ getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
toolAlreadyInstalled :: Tool -> Version -> IO Bool
toolAlreadyInstalled tool ver = case tool of
GHC -> ghcInstalled ver
Cabal -> cabalInstalled ver
GHCup -> pure True
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
ghcSrcInstalled :: Version -> IO Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
ghcSet = do
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
-- link destination is of the form ../ghc/<ver>/bin/ghc
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
reportedVer <- cabalSet
pure (reportedVer == ver)
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
case version (E.decodeUtf8 reportedVer) of
Left e -> throwM e
Right r -> pure r
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do
SemVer {..} <- throwEither (semver $ prettyVer ver)
pure (fromIntegral _svMajor, fromIntegral _svMinor)
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (MonadIO m, MonadThrow m)
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> m (Maybe Version)
getGHCForMajor major' minor' = do
p <- liftIO $ ghcupGHCBaseDir
ghcs <- liftIO $ getDirsFiles' p
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
mapM (throwEither . version)
. fmap prettySemVer
. lastMay
. sort
. filter
(\SemVer {..} ->
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
)
$ semvers
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive] m ()
unpackToDir dest av = do
let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|]
fn <- toFilePath <$> basename av
let untar = Tar.unpack (toFilePath dest) . Tar.read
-- extract, depending on file extension
if
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
(untar . GZip.decompress =<< readFile av)
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents
liftIO $ untar decompressed
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
(untar . BZip.decompress =<< readFile av)
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn
------------
--[ Tags ]--
------------
-- | Get the tool versions that have this tag.
getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: GHCupDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
-----------------------
--[ Settings Getter ]--
-----------------------
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks.
--
-- Returns unversioned relative files, e.g.:
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC ver))
files <- liftIO $ getDirsFiles' bindir
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
(Just symver) <-
(B.stripPrefix [s|ghc-|] . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]

69
lib/GHCup/Utils/Bash.hs Normal file
View File

@ -0,0 +1,69 @@
module GHCup.Utils.Bash
( findAssignment
, equalsAssignmentWith
, getRValue
, getAssignmentValueFor
)
where
import Control.Monad
import Data.ByteString.UTF8 ( toString )
import Data.List
import Data.Maybe
import HPath
import HPath.IO
import Language.Bash.Parse
import Language.Bash.Syntax
import Language.Bash.Word
import Prelude hiding ( readFile )
import qualified Data.ByteString.Lazy.UTF8 as UTF8
extractAssignments :: List -> [Assign]
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
where
getCommands :: [Statement] -> [Command]
getCommands = join . fmap commands . catMaybes . fmap findPipes
where
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
findPipes _ = Nothing
getAssign :: Command -> [Assign]
getAssign (Command (SimpleCommand ass _) _) = ass
getAssign _ = []
-- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
findAssignment p predicate = do
fileContents <- readFile p
-- TODO: this should accept bytestring:
-- https://github.com/knrafto/language-bash/issues/37
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
Left e -> fail $ show e
Right l -> pure $ find predicate (extractAssignments $ l)
-- | Check that the assignment is of the form Foo= ignoring the
-- right hand-side.
equalsAssignmentWith :: String -> Assign -> Bool
equalsAssignmentWith n ass = case ass of
(Assign (Parameter name' Nothing) Equals _) -> n == name'
_ -> False
-- | This pretty-prints the right hand of an Equals assignment, removing
-- quotations. No evaluation is performed.
getRValue :: Assign -> Maybe String
getRValue ass = case ass of
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
_ -> Nothing
-- | Given a bash assignment such as Foo="Bar" in the given file,
-- will return "Bar" (without quotations).
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
getAssignmentValueFor p n = do
mass <- findAssignment p (equalsAssignmentWith n)
pure (mass >>= getRValue)

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

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

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

@ -0,0 +1,246 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Data.ByteString
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.Maybe
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
import HPath
import HPath.IO
import Optics
import Streamly
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.IO
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import qualified System.Posix.Process.ByteString
as SPPB
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Data.ByteString.Lazy as L
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
, _stdErr :: ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
-- | Read the lines of a file into a stream. The stream holds
-- a file handle as a resource and will close it once the stream
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream p
pure
. (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n')
. (fmap toArray)
$ stream
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
-- This shouldn't throw IO exceptions, unless getting the environment variable
-- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
sPaths
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO CapturedProcess
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
let logfile = ldir </> lfile
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo fd stdOutput
-- dup stderr
void $ dupTo fd stdError
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
void $ action
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
SPPB.getProcessStatus True True pid >>= \case
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
where
actionWithPipes a =
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> Path b -> IO Fd
createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
-- | Thin wrapper around `executeFile`.
exec :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
exec exe spath args chdir env = do
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
unsafePathToString p = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM PermissionDenied (go xs)
$ hideErrorDefM NoSuchThing (go xs)
$ do
dirStream <- openDirStream (toFilePath x)
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
>>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == toFilePath needle
then isExecutable (basedir </> needle)
else pure False

60
lib/GHCup/Utils/Logger.hs Normal file
View File

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

243
lib/GHCup/Utils/Prelude.hs Normal file
View File

@ -0,0 +1,243 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.Prelude where
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Monoid ( (<>) )
import Data.String
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
fS :: IsString a => String -> a
fS = fromString
fromStrictMaybe :: S.Maybe a -> Maybe a
fromStrictMaybe = S.maybe Nothing Just
fSM :: S.Maybe a -> Maybe a
fSM = fromStrictMaybe
toStrictMaybe :: Maybe a -> S.Maybe a
toStrictMaybe = maybe S.Nothing S.Just
tSM :: Maybe a -> S.Maybe a
tSM = toStrictMaybe
internalError :: String -> IO a
internalError = fail . ("Internal error: " <>)
iE :: String -> IO a
iE = internalError
showT :: Show a => a -> Text
showT = fS . show
-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM ~b ~t = ifM b t (return ())
-- | Like 'unless', but where the test can be monadic.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM ~b ~f = ifM b (return ()) f
-- | Like @if@, but where the test can be monadic.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM ~b ~t ~f = do
b' <- b
if b' then t else f
whileM :: Monad m => m a -> (a -> m Bool) -> m a
whileM ~action ~f = do
a <- action
b' <- f a
if b' then whileM action f else pure a
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ ~action = void . whileM action
guardM :: (Monad m, Alternative m) => m Bool -> m ()
guardM ~f = guard =<< f
lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8
handleIO' :: (MonadIO m, MonadCatch m)
=> IOErrorType
-> (IOException -> m a)
-> m a
-> m a
handleIO' err handler = handleIO
(\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
(??) m e = maybe (throwE e) pure m
(!?) :: forall e es a m
. (Monad m, e :< es)
=> m (Maybe a)
-> e
-> Excepts es m a
(!?) em e = lift em >>= (?? e)
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
lE = liftE . veitherToExcepts . fromEither
lE' :: forall e' e es a m
. (Monad m, e :< es)
=> (e' -> e)
-> Either e' a
-> Excepts es m a
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE
lEM' :: forall e' e es a m
. (Monad m, e :< es)
=> (e' -> e)
-> m (Either e' a)
-> Excepts es m a
lEM' f em = lift em >>= lE . bimap f id
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
liftIOException' :: ( MonadCatch m
, MonadIO m
, Monad m
, e :< es'
, LiftVariant es es'
)
=> IOErrorType
-> e
-> Excepts es m a
-> Excepts es' m a
liftIOException' errType ex =
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
)
. liftE
liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
=> IOErrorType
-> e
-> m a
-> Excepts es' m a
liftIOException errType ex =
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
)
. lift
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
hideErrorDef err def =
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
hideErrorDefM err def =
handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
-- TODO: does this work?
hideExcept :: forall e es es' a m
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
-> a
-> Excepts es m a
-> Excepts es' m a
hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
hideExcept' :: forall e es es' m
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
-> Excepts es m ()
-> Excepts es' m ()
hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
reThrowAll :: forall e es es' a m
. (Monad m, e :< es')
=> (V es -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAll f = catchAllE (throwE . f)
reThrowAllIO :: forall e es es' a m
. (MonadCatch m, Monad m, MonadIO m, e :< es')
=> (V es -> e)
-> (IOException -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment
pure (adds ++ cEnv)

48
lib/GHCup/Utils/String/QQ.hs Normal file
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)

11
lib/GHCup/Version.hs Normal file
View File

@ -0,0 +1,11 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Version where
import GHCup.Utils.Version.QQ
import Data.Versions
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.0|]

4
test/MyLibTest.hs Normal file
View File

@ -0,0 +1,4 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."

66
update-index-state.sh Executable file
View File

@ -0,0 +1,66 @@
#!/usr/bin/env bash
set -eu
status_message() {
printf "\\033[0;32m%s\\033[0m\\n" "$1"
}
error_message() {
printf "\\033[0;31m%s\\033[0m\\n" "$1"
}
SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
if [ ! -f "${CACHE_LOCATION}" ] ; then
error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
exit 1
fi
if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
exit 3
fi
cabal v2-update
arch=$(getconf LONG_BIT)
case "${arch}" in
32)
byte_size=4
magic_word="CABA1002"
;;
64)
byte_size=8
magic_word="00000000CABA1002"
;;
*)
error_message "Unknown architecture (long bit): ${arch}"
exit 2
;;
esac
# This is the logic to parse the binary format of 01-index.cache.
# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
# Better than copying the cabal-install source code.
if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
error_message "Magic word does not match!"
exit 4
fi
cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
# If we got junk from the binary file, this should fail.
cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
else
printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
fi