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 * download progress
* Downloads from URL
* set Set currently active GHC version
* list Show available GHCs and other tools
* upgrade Upgrade this script in-place * upgrade Upgrade this script in-place
* rm Remove an already installed GHC * rm Remove an already installed GHC
* debug-info Print debug info (e.g. detected system/distro) * debug-info Print debug info (e.g. detected system/distro)
* changelog Show the changelog of a GHC release (online) * changelog Show the changelog of a GHC release (online)
* print-system-reqs Print an approximation of system requirements * print-system-reqs Print an approximation of system requirements
* install major ver
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
* TODO: cleanup temp files after use
## Old ## 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 HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
common aeson { build-depends: aeson >= 1.4 } 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 ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 } common async { build-depends: async >= 0.8 }
common base { build-depends: base >= 4.12 && < 5 } 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 optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
common parsec { build-depends: parsec >= 3.1 } common parsec { build-depends: parsec >= 3.1 }
common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 } 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 safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } common streamly { build-depends: streamly >= 0.7 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 } common strict-base { build-depends: strict-base >= 0.4 }
common string-qq { build-depends: string-qq >= 0.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 tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 } common text { build-depends: text >= 1.2 }
@ -87,6 +92,7 @@ library
, aeson , aeson
, ascii-string , ascii-string
, async , async
, attoparsec
, bytestring , bytestring
, bzlib , bzlib
, containers , containers
@ -106,11 +112,14 @@ library
, optics , optics
, optics-vl , optics-vl
, parsec , parsec
, pretty-terminal
, safe
, safe-exceptions , safe-exceptions
, streamly , streamly
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-qq , string-qq
, string-interpolate
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
, text , text
@ -127,6 +136,7 @@ library
exposed-modules: GHCup exposed-modules: GHCup
GHCup.Bash GHCup.Bash
GHCup.File GHCup.File
GHCup.Logger
GHCup.Prelude GHCup.Prelude
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
@ -138,7 +148,9 @@ library
executable ghcup executable ghcup
import: config import: config
, base , base
--
, bytestring , bytestring
, containers
, haskus-utils-variant , haskus-utils-variant
, monad-logger , monad-logger
, mtl , mtl
@ -148,11 +160,46 @@ executable ghcup
, hpath , hpath
, pretty-terminal , pretty-terminal
, string-qq , string-qq
, table-layout
, uri-bytestring
, utf8-string
main-is: Main.hs main-is: Main.hs
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: ghcup 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 default-language: Haskell2010
test-suite ghcup-test test-suite ghcup-test

673
lib/GHCup.hs
View File

@ -23,15 +23,21 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Exception.Safe import Control.Exception.Safe
import Data.Aeson
import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Foldable ( asum ) import Data.Foldable ( asum )
import Data.String.QQ import Data.String.QQ
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Data.IORef
import GHCup.Bash import GHCup.Bash
import GHCup.File import GHCup.File
import GHCup.Prelude import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON
import GHCup.Types.Optics import GHCup.Types.Optics
import HPath import HPath
import HPath.IO import HPath.IO
@ -39,8 +45,10 @@ import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, readFile , readFile
) )
import Data.List
import System.Info import System.Info
import System.IO.Error import System.IO.Error
import Data.Foldable ( foldrM )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU import qualified Data.Text.ICU as ICU
@ -90,14 +98,21 @@ import System.Posix.Directory.ByteString
( changeWorkingDirectory ) ( changeWorkingDirectory )
import URI.ByteString import URI.ByteString
import URI.ByteString.QQ import URI.ByteString.QQ
import Data.String.Interpolate
import Safe
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, urlSource :: URLSource
} }
deriving Show 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 data NotInstalled = NotInstalled ToolRequest
deriving Show 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 ghcupURL :: URI
availableDownloads :: AvailableDownloads ghcupURL =
availableDownloads = Map.fromList [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
[ ( 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
)
]
)
]
)
]
)
]
)
]
-- | Get the tool versions that have this tag. -- | 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 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 ]-- --[ Download stuff ]--
---------------------- ----------------------
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m) getDownloadInfo :: ( MonadLogger m
, MonadCatch m
, MonadIO m
, MonadReader Settings m
)
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -> Maybe PlatformRequest
-> URLSource
-> Excepts -> Excepts
'[ PlatformResultError '[ PlatformResultError
, NoDownload , NoDownload
, NoCompatibleArch , NoCompatibleArch
, DistroNotFound , DistroNotFound
, URLException
, JSONError
] ]
m m
DownloadInfo DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do getDownloadInfo (ToolRequest t v) mpfReq = do
lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource) urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
-- lift $ monadLoggerLog undefined undefined undefined "" -- lift $ monadLoggerLog undefined undefined undefined ""
(PlatformRequest arch plat ver) <- case mpfReq of (PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x Just x -> pure x
@ -260,11 +242,7 @@ getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
ar <- lE getArchitecture ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv pure $ PlatformRequest ar rp rv
dls <- case urlSource of dls <- liftE $ getDownloads
-- TODO
GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
lE $ getDownloadInfo' t v arch plat ver dls 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 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 -- | Same as `download'`, except uses URL type. As such, this might
-- 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
-- throw an exception if the url type or host protocol is not supported. -- throw an exception if the url type or host protocol is not supported.
-- --
-- Only Absolute HTTP/HTTPS is supported. -- Only Absolute HTTP/HTTPS is supported.
download' :: (MonadLogger m, MonadIO m) download :: (MonadLogger m, MonadIO m)
=> DownloadInfo => DownloadInfo
-> Path Abs -- ^ destination dir -> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[URLException] m (Path Abs) -> 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|https|] = dl True
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
| otherwise = throwE UnsupportedURL | otherwise = throwE UnsupportedURL
where where
dl https = do dl https = do
lift $ $(logInfo) let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli))) lift $ $(logInfo) [i|downloading: #{uri}|]
host <- host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL ?? UnsupportedURL
@ -336,65 +297,49 @@ download' dli dest mfn
let port = preview let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL') (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli 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?
-> 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 downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString
-> ByteString downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True
-> ByteString | view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False
-> Maybe Int | otherwise = throwE UnsupportedURL
-> 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
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)
-> 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 where
-- Manage to find a file we can write the body into. -- Manage to find a file we can write the body into.
getFile :: Path Abs -> Maybe (Path Rel) -> IO (Fd, Path Abs) getFile :: IO (Fd, Path Abs)
getFile dest mfn = do getFile = do
-- destination dir must exist -- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of case mfn of
@ -409,6 +354,50 @@ downloadInternal https host path port dest = do
fmap (, fp) $ createRegularFileFd newFilePerms fp 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 ]-- --[ Platform detection ]--
@ -440,7 +429,7 @@ getPlatform = do
ver <- getFreeBSDVersion ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE NoCompatiblePlatform what -> throwE NoCompatiblePlatform
lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr) lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr pure pfr
where getFreeBSDVersion = pure Nothing where getFreeBSDVersion = pure Nothing
@ -547,7 +536,8 @@ getLinuxDistro = do
-- TODO: custom logger intepreter and pretty printing -- 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 -- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal. -- `AlreadyInstalled` to not make it fatal.
@ -560,7 +550,6 @@ installTool :: ( MonadThrow m
) )
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> URLSource
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, FileError , FileError
@ -572,18 +561,20 @@ installTool :: ( MonadThrow m
, NoCompatibleArch , NoCompatibleArch
, DistroNotFound , DistroNotFound
, NotInstalled , NotInstalled
, URLException
, JSONError
] ]
m m
() ()
installTool treq mpfReq urlSource = do installTool treq mpfReq = do
lift $ $(logDebug) ([s|Requested to install: |] <> showT treq) lift $ $(logDebug) [i|Requested to install: #{treq}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq) when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
Settings {..} <- lift ask Settings {..} <- lift ask
-- download (or use cached version) -- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource dlinfo <- liftE $ getDownloadInfo treq mpfReq
dl <- case cache of dl <- case cache of
True -> do True -> do
cachedir <- liftIO $ ghcupCacheDir cachedir <- liftIO $ ghcupCacheDir
@ -592,10 +583,10 @@ installTool treq mpfReq urlSource = do
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> pure $ cachfile | fileExists -> pure $ cachfile
| otherwise -> liftE $ download' dlinfo cachedir Nothing | otherwise -> liftE $ download dlinfo cachedir Nothing
False -> do False -> do
tmp <- liftIO mkGhcupTmpDir tmp <- liftIO mkGhcupTmpDir
liftE $ download' dlinfo tmp Nothing liftE $ download dlinfo tmp Nothing
-- unpack -- unpack
unpacked <- liftE $ unpackToTmpDir dl unpacked <- liftE $ unpackToTmpDir dl
@ -607,11 +598,15 @@ installTool treq mpfReq urlSource = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo) let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
-- TODO: test if tool is already installed
case treq of case treq of
(ToolRequest GHC ver) -> do (ToolRequest GHC ver) -> do
liftE $ installGHC archiveSubdir ghcdir liftE $ installGHC archiveSubdir ghcdir
liftE $ setGHC ver 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 (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
@ -629,7 +624,7 @@ installGHC :: (MonadLogger m, MonadIO m)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installGHC path inst = do installGHC path inst = do
lift $ $(logInfo) ([s|Installing GHC|]) lift $ $(logInfo) [s|Installing GHC|]
lEM $ liftIO $ exec [s|./configure|] lEM $ liftIO $ exec [s|./configure|]
[[s|--prefix=|] <> toFilePath inst] [[s|--prefix=|] <> toFilePath inst]
False False
@ -644,7 +639,7 @@ installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m () -> Excepts '[FileError] m ()
installCabal path inst = do installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|]) lift $ $(logInfo) [s|Installing cabal|]
let cabalFile = [rel|cabal|] :: Path Rel let cabalFile = [rel|cabal|] :: Path Rel
liftIO $ createDirIfMissing newDirPerms inst liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
@ -653,12 +648,19 @@ installCabal path inst = do
Overwrite Overwrite
---------------
--[ Set GHC ]--
---------------
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends -- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`: -- on `SetGHC`:
-- --
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.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-<ver> -- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver> -- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
-- --
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink -- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor. -- for `SetGHCOnly` constructor.
@ -667,67 +669,204 @@ setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
-> SetGHC -> SetGHC
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
setGHC ver sghc = do setGHC ver sghc = do
let verBS = E.encodeUtf8 $ prettyVer ver -- as ByteString let verBS = verToBS ver
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination -- symlink destination
destdir <- liftIO $ ghcupBinDir destdir <- liftIO $ ghcupBinDir
liftIO $ createDirIfMissing newDirPerms destdir liftIO $ createDirIfMissing newDirPerms destdir
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ghcdir verfiles <- ghcToolFiles ver
forM verfiles $ \file -> do forM verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file) liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of targetFile <- case sghc of
SetGHCOnly -> pure file SetGHCOnly -> pure file
SetGHCMajor -> do 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) parseRel (toFilePath file <> B.singleton _hyphen <> major)
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ createSymlink liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> targetFile) (destdir </> targetFile)
([s|../ghc/|] <> verBS <> [s|/bin/|] <> toFilePath file) liftIO $ createSymlink (destdir </> targetFile)
(ghcLinkDestination (toFilePath file) ver)
-- create symlink for share dir -- create symlink for share dir
liftIO $ symlinkShareDir ghcdir destdir verBS liftIO $ symlinkShareDir ghcdir verBS
pure () pure ()
where 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)) symlinkShareDir :: Path Abs -> ByteString -> IO ()
-- figure out the <ver> suffix, because this might not be `Version` for symlinkShareDir ghcdir verBS = do
-- alpha/rc releases, but x.y.a.somedate. destdir <- ghcupBaseDir
(Just symver) <- case sghc of
(B.stripPrefix [s|ghc-|] . takeFileName) SetGHCOnly -> do
<$> (liftIO $ readSymbolicLink $ toFilePath let sharedir = [rel|share|] :: Path Rel
(ghcdir </> ([rel|bin/ghc|] :: Path Rel)) let fullsharedir = ghcdir </> sharedir
) whenM (doesDirectoryExist fullsharedir) $ do
when (B.null symver) liftIO $ hideError doesNotExistErrorType $ deleteFile
(throwIO $ userError $ "Fatal: ghc symlink target is broken") (destdir </> sharedir)
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files createSymlink
(destdir </> sharedir)
([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> 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)
symlinkShareDir :: Path Abs -> Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir destdir verBS = case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> sharedir)
createSymlink
(destdir </> sharedir)
([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> pure ()
----------------- -----------------
@ -746,14 +885,43 @@ ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs) ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (E.encodeUtf8 $ prettyVer ver) verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir) 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 :: Version -> IO Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir 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 :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel)) ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
@ -765,17 +933,43 @@ cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc 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. -- | 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 getGHCMajor ver = do
semv <- case semver $ prettyVer ver of SemVer {..} <- throwEither (semver $ prettyVer ver)
Right v -> pure v pure (fromIntegral _svMajor, fromIntegral _svMinor)
Left e -> throwM e
pure $ T.pack (show (_svMajor semv)) <> T.pack "." <> T.pack
(show (_svMinor semv)) -- | 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 urlBaseName :: MonadThrow m
@ -790,7 +984,8 @@ unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path => Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs) -> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do 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 fn <- toFilePath <$> basename av
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|]) tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
@ -810,3 +1005,29 @@ unpackToTmpDir av = do
(untar . BZip.decompress =<< readFile av) (untar . BZip.decompress =<< readFile av)
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av) | [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn | 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
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe import Control.Exception.Safe
import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.Strict.Maybe as S import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String 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.Encoding as TLE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text ( Text ) import Data.Text ( Text )
import qualified Data.Text.Encoding as E
import qualified Data.Text as T import qualified Data.Text as T
import Data.Versions import Data.Versions
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -94,7 +99,7 @@ lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8 lBS2sT = TL.toStrict . TLE.decodeUtf8
handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO () handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
handleIO' err handler = handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) 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 :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
lE = liftE . veitherToExcepts . fromEither 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 :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE 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 a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight fromEither = either (VLeft . V) VRight
@ -130,6 +149,12 @@ hideExcept h a action =
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m 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 Versioning
deriving instance Lift Version deriving instance Lift Version
@ -181,3 +206,12 @@ pver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . pvp 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 data Tag = Latest
| Recommended | Recommended
deriving (Eq, Show) deriving (Ord, Eq, Show)
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ _viTags :: [Tag] { _viTags :: [Tag]

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

@ -6,7 +6,8 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Types.JSON where module GHCup.Types.JSON where
@ -20,7 +21,11 @@ import Data.Text.Encoding ( decodeUtf8
) )
import Data.Aeson.Types import Data.Aeson.Types
import Data.Text.Encoding as E import Data.Text.Encoding as E
import HPath
import URI.ByteString 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 ''Tool
deriveJSON defaultOptions ''VSep deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo
instance ToJSON URI where instance ToJSON URI where
@ -127,3 +135,17 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions 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