More stuff
This commit is contained in:
parent
30ed7f0226
commit
6489e8430b
5
TODO.md
5
TODO.md
@ -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
177
app/Main.hs
@ -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
127
app/ghcup-gen/AvailableDownloads.hs
Normal 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
144
app/ghcup-gen/Main.hs
Normal 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
104
app/ghcup-gen/Validate.hs
Normal 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
382
app/ghcup/Main.hs
Normal 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
49
ghcup.cabal
@ -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
|
||||||
|
637
lib/GHCup.hs
637
lib/GHCup.hs
@ -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.
|
downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString
|
||||||
downloadFd :: Bool -- ^ https?
|
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 -- ^ host (e.g. "www.example.com")
|
||||||
-> ByteString -- ^ path (e.g. "/my/file")
|
-> ByteString -- ^ path (e.g. "/my/file")
|
||||||
-> Maybe Int -- ^ optional port (e.g. 3000)
|
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||||
-> Fd -- ^ function creating an Fd to write the body into
|
-> Path Abs -- ^ destination directory to download into
|
||||||
-> IO ()
|
-> Maybe (Path Rel) -- ^ optionally provided filename
|
||||||
downloadFd https host path port fd =
|
-> IO (Path Abs)
|
||||||
void $ downloadInternal https host path port (Left fd)
|
download' https host path port dest mfn = do
|
||||||
|
(fd, fp) <- getFile
|
||||||
|
let stepper = fdWrite fd
|
||||||
downloadInternal :: Bool
|
flip finally (closeFd fd) $ downloadInternal https host path port stepper
|
||||||
-> ByteString
|
pure fp
|
||||||
-> 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
|
|
||||||
|
|
||||||
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,7 +669,7 @@ 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
|
||||||
@ -675,49 +677,33 @@ setGHC ver sghc = do
|
|||||||
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)
|
|
||||||
<$> (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
|
|
||||||
SetGHCOnly -> do
|
SetGHCOnly -> do
|
||||||
let sharedir = [rel|share|] :: Path Rel
|
let sharedir = [rel|share|] :: Path Rel
|
||||||
let fullsharedir = ghcdir </> sharedir
|
let fullsharedir = ghcdir </> sharedir
|
||||||
@ -730,6 +716,159 @@ setGHC ver sghc = do
|
|||||||
_ -> pure ()
|
_ -> 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 ]--
|
--[ Utilities ]--
|
||||||
-----------------
|
-----------------
|
||||||
@ -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
50
lib/GHCup/Logger.hs
Normal 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)
|
||||||
|
|
@ -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
|
||||||
|
@ -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]
|
||||||
|
@ -7,6 +7,7 @@
|
|||||||
{-# 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
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user