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

More stuff

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

5
TODO.md
View File

@ -4,17 +4,16 @@
* download progress
* Downloads from URL
* set Set currently active GHC version
* list Show available GHCs and other tools
* upgrade Upgrade this script in-place
* rm Remove an already installed GHC
* debug-info Print debug info (e.g. detected system/distro)
* changelog Show the changelog of a GHC release (online)
* print-system-reqs Print an approximation of system requirements
* install major ver
* testing (especially distro detection -> unit tests)
* TODO: cleanup temp files after use
## Old

177
app/Main.hs
View File

@ -1,177 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Functor ( (<&>) )
import Data.Maybe
import Data.Semigroup ( (<>) )
import Data.String.QQ
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable
import Data.Versions
import GHCup
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative
import System.Console.Pretty
import System.Exit
data Options = Options
{ optVerbose :: Bool
, optCache :: Bool
, optCommand :: Command
}
data Command
= InstallGHC InstallGHCOptions
| InstallCabal InstallCabalOptions
data InstallGHCOptions = InstallGHCOptions
{ ghcVer :: Maybe Version
}
data InstallCabalOptions = InstallCabalOptions
{ cabalVer :: Maybe Version
}
opts :: Parser Options
opts =
Options
<$> switch
(short 'v' <> long "verbose" <> help "Whether to enable verbosity")
<*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
<*> com
com :: Parser Command
com = subparser
( command
"install-ghc"
( InstallGHC
<$> (info (installGHCOpts <**> helper)
(progDesc "Install a GHC version")
)
)
<> command
"install-cabal"
( InstallCabal
<$> (info (installCabalOpts <**> helper)
(progDesc "Install a cabal-install version")
)
)
)
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts = InstallGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to install"
)
)
installCabalOpts :: Parser InstallCabalOptions
installCabalOpts = InstallCabalOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The Cabal version to install"
)
)
toSettings :: Options -> Settings
toSettings Options {..} = let cache = optCache in Settings { .. }
-- TODO: something better than Show instance for errors
main :: IO ()
main = do
-- logger interpreter
let runLogger = runStderrLoggingT
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- wrapper to run effects with settings
let runInstTool =
runLogger
. flip runReaderT settings
. runE
@'[ FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, TagNotFound
, AlreadyInstalled
, NotInstalled
]
case optCommand of
InstallGHC (InstallGHCOptions {..}) ->
void
$ (runInstTool $ do
v <- maybe
( getRecommended availableDownloads GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
liftE $ installTool (ToolRequest GHC v)
Nothing
(OwnSpec availableDownloads)
)
>>= \case
VRight _ -> runLogger $ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
InstallCabal (InstallCabalOptions {..}) ->
void
$ (runInstTool $ do
v <- maybe
( getRecommended availableDownloads Cabal
?? TagNotFound Recommended Cabal
)
pure
cabalVer
liftE $ installTool (ToolRequest Cabal v)
Nothing
(OwnSpec availableDownloads)
)
>>= \case
VRight _ -> runLogger $ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
pure ()

127
app/ghcup-gen/AvailableDownloads.hs Normal file
View File

@ -0,0 +1,127 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module AvailableDownloads where
import qualified Data.Map as M
import GHCup.Prelude
import GHCup.Types
import HPath
import URI.ByteString.QQ
-- TODO: version quasiquoter
availableDownloads :: AvailableDownloads
availableDownloads = M.fromList
[ ( GHC
, M.fromList
[ ( [ver|8.6.5|]
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Ubuntu
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Debian
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
, ( Just $ [vers|8|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
]
)
]
),
( [ver|8.4.4|]
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.4.4|] :: Path Rel))
)
]
)
, ( Linux Ubuntu
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
(Just ([rel|ghc-8.4.4|] :: Path Rel))
)
]
)
, ( Linux Debian
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
, ( Just $ [vers|8|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
]
)
]
)
]
)
, ( Cabal
, M.fromList
[ ( [ver|3.0.0.0|]
, VersionInfo [Recommended, Latest] $ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
Nothing
)
]
)
]
)
]
)
]
)
]

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

@ -0,0 +1,144 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
import AvailableDownloads
import Data.Aeson ( eitherDecode )
import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy as L
import Data.Semigroup ( (<>) )
import GHCup.Types.JSON ( )
import Options.Applicative hiding ( style )
import Control.Monad.Logger
import GHCup.Logger
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import Validate
data Options = Options
{ optCommand :: Command
}
data Command = GenJSON GenJSONOpts
| ValidateJSON 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 "Generate the json downloads file")
)
)
)
)
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 })
availableDownloads
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
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit
pure ()
where
valAndExit contents = do
av <- case eitherDecode contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerTStdout (validate av) >>= exitWith

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

@ -0,0 +1,104 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
module Validate where
import AvailableDownloads
import GHCup
import GHCup.Types
import GHCup.Types.Optics
import Control.Monad
import Control.Exception.Safe
import Control.Monad.Reader.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( ReaderT
, runReaderT
)
import Data.List
import Data.String.QQ
import Data.String.Interpolate
import Data.Versions
import Data.IORef
import Optics
import System.Exit
import System.Console.Pretty
import System.IO
import Control.Monad.Logger
import qualified Data.Map.Strict as M
import qualified Data.ByteString as B
-- TODO: improve logging
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
-- TODO: test that GHC is in semver
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
=> AvailableDownloads
-> m ExitCode
validate av = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList av) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs)
-- exit
e <- liftIO $ readIORef ref
if e > 0 then pure $ ExitFailure e else 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) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
addError
when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions av 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: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)

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

@ -0,0 +1,382 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.ByteString ( ByteString )
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import Data.Functor ( (<&>) )
import Data.List ( intercalate )
import qualified Data.Map as M
import Data.Maybe
import Data.Semigroup ( (<>) )
import Data.String.QQ
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable
import Data.Versions
import GHCup
import GHCup.Logger
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Exit
import URI.ByteString
import Text.Layout.Table
data Options = Options
{ optVerbose :: Bool
, optCache :: Bool
, optUrlSource :: Maybe URI
, optCommand :: Command
}
data Command
= InstallGHC InstallGHCOptions
| InstallCabal InstallCabalOptions
| SetGHC SetGHCOptions
| List ListOptions
| Rm RmOptions
data InstallGHCOptions = InstallGHCOptions
{ ghcVer :: Maybe Version
}
data InstallCabalOptions = InstallCabalOptions
{ cabalVer :: Maybe Version
}
data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe Version
}
data ListOptions = ListOptions
{ lTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
}
data RmOptions = RmOptions
{ ghcVer :: Version
}
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 (default: internal)"
)
)
)
<*> com
where
parseUri s =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s)
com :: Parser Command
com = subparser
( command
"install-ghc"
( InstallGHC
<$> (info (installGHCOpts <**> helper)
(progDesc "Install a GHC version")
)
)
<> command
"install-cabal"
( InstallCabal
<$> (info (installCabalOpts <**> helper)
(progDesc "Install a cabal-install version")
)
)
<> command
"set-ghc"
( SetGHC
<$> (info (setGHCOpts <**> helper)
(progDesc "Set the currently active GHC version")
)
)
<> command
"list"
( List
<$> (info (listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
)
<> command
"rm"
( Rm
<$> (info (rmOpts <**> helper)
(progDesc "Remove a GHC version installed by ghcup")
)
)
)
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts = InstallGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to install"
)
)
installCabalOpts :: Parser InstallCabalOptions
installCabalOpts = InstallCabalOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The Cabal version to install"
)
)
setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to set (default: recommended)"
)
)
listOpts :: Parser ListOptions
listOpts =
ListOptions
<$> optional
(option
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
"Tool to list versions for. Default is ghc only."
)
)
<*> (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 <$>
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to remove"
)
)
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
in Settings { .. }
-- TODO: something better than Show instance for errors
main :: IO ()
main = do
-- logger interpreter
let runLogger = myLoggerTStderr
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- wrapper to run effects with settings
let runInstTool =
runLogger
. flip runReaderT settings
. runE
@'[ FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, TagNotFound
, AlreadyInstalled
, NotInstalled
, JSONError
]
let runSetGHC =
runLogger
. flip runReaderT settings
. runE @'[NotInstalled , TagNotFound, URLException , JSONError]
let runListGHC =
runLogger
. flip runReaderT settings
. runE @'[URLException , JSONError]
let runRmGHC =
runLogger
. flip runReaderT settings
. runE @'[NotInstalled]
case optCommand of
InstallGHC (InstallGHCOptions {..}) ->
void
$ (runInstTool $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest GHC v)
Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
InstallCabal (InstallCabalOptions {..}) ->
void
$ (runInstTool $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av Cabal
?? TagNotFound Recommended Cabal
)
pure
cabalVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest Cabal v)
Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
SetGHC (SetGHCOptions {..}) ->
void
$ (runSetGHC $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight _ ->
runLogger $ $(logInfo) ([s|GHC successfully set|])
VLeft e -> die (color Red $ show e)
List (ListOptions {..}) ->
void
$ (runListGHC $ do
liftE $ listVersions lTool lCriteria
)
>>= \case
VRight r -> liftIO $ printListResult r
VLeft e -> die (color Red $ show e)
Rm (RmOptions {..}) ->
void
$ (runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ()
VLeft e -> die (color Red $ show e)
pure ()
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
]
$ 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)
]
)
lr
putStrLn $ formatted

49
ghcup.cabal
View File

@ -22,6 +22,8 @@ source-repository head
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 attoparsec { build-depends: attoparsec >= 0.13 }
common ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 }
common base { build-depends: base >= 4.12 && < 5 }
@ -46,11 +48,14 @@ 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 safe { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 }
common string-qq { build-depends: string-qq >= 0.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.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 }
@ -87,6 +92,7 @@ library
, aeson
, ascii-string
, async
, attoparsec
, bytestring
, bzlib
, containers
@ -106,11 +112,14 @@ library
, optics
, optics-vl
, parsec
, pretty-terminal
, safe
, safe-exceptions
, streamly
, streamly-bytestring
, strict-base
, string-qq
, string-interpolate
, tar-bytestring
, template-haskell
, text
@ -127,6 +136,7 @@ library
exposed-modules: GHCup
GHCup.Bash
GHCup.File
GHCup.Logger
GHCup.Prelude
GHCup.Types
GHCup.Types.JSON
@ -138,7 +148,9 @@ library
executable ghcup
import: config
, base
--
, bytestring
, containers
, haskus-utils-variant
, monad-logger
, mtl
@ -148,11 +160,46 @@ executable ghcup
, hpath
, pretty-terminal
, string-qq
, table-layout
, uri-bytestring
, utf8-string
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app
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
, string-qq
, string-interpolate
, table-layout
, transformers
, uri-bytestring
, utf8-string
main-is: Main.hs
other-modules: AvailableDownloads
Validate
-- other-extensions:
build-depends: ghcup
hs-source-dirs: app/ghcup-gen
default-language: Haskell2010
test-suite ghcup-test

637
lib/GHCup.hs
View File

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

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

@ -0,0 +1,50 @@
module GHCup.Logger where
import GHCup
import GHCup.Types
import GHCup.Types.Optics
import Control.Monad
import Control.Exception.Safe
import Control.Monad.Reader.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( ReaderT
, runReaderT
)
import Data.List
import Data.String.QQ
import Data.String.Interpolate
import Data.Versions
import Data.IORef
import Optics
import System.Exit
import System.Console.Pretty
import System.IO
import Control.Monad.Logger
import qualified Data.Map.Strict as M
import qualified Data.ByteString as B
myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
myLoggerT outter loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger loc source level str = do
let l = case level of
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str <> toLogStr "\n")
outter out
myLoggerTStdout :: LoggingT m a -> m a
myLoggerTStdout = myLoggerT (B.hPut stdout)
myLoggerTStderr :: LoggingT m a -> m a
myLoggerTStderr = myLoggerT (B.hPut stderr)

36
lib/GHCup/Prelude.hs
View File

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

2
lib/GHCup/Types.hs
View File

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

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

@ -7,6 +7,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Types.JSON where
@ -20,7 +21,11 @@ import Data.Text.Encoding ( decodeUtf8
)
import Data.Aeson.Types
import Data.Text.Encoding as E
import HPath
import URI.ByteString
import Data.Word8
import qualified Data.ByteString as BS
import Data.String.QQ
@ -33,6 +38,9 @@ deriveJSON defaultOptions ''SemVer
deriveJSON defaultOptions ''Tool
deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo
instance ToJSON URI where
@ -127,3 +135,17 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . E.decodeUtf8 $ fp
False -> String [s|/not/a/valid/path|]
where fp = toFilePath p
instance FromJSON (Path Rel) where
parseJSON = withText "HPath Rel" $ \t -> do
let d = encodeUtf8 t
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e