More stuff

This commit is contained in:
2020-02-29 00:33:32 +01:00
parent 30ed7f0226
commit 6489e8430b
12 changed files with 1363 additions and 410 deletions

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 ()

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