Lala
This commit is contained in:
parent
d598c42d19
commit
62b249db2d
24
TODO.md
24
TODO.md
@ -1,33 +1,39 @@
|
||||
# TODOs and Remarks
|
||||
|
||||
## New
|
||||
## Now
|
||||
|
||||
* better logs
|
||||
* better debug-output
|
||||
|
||||
* download progress
|
||||
* upgrade Upgrade this script in-place
|
||||
* reference tarballs in json
|
||||
|
||||
|
||||
## Maybe
|
||||
|
||||
* maybe: download progress
|
||||
* maybe: changelog Show the changelog of a GHC release (online)
|
||||
* maybe: print-system-reqs Print an approximation of system requirements
|
||||
|
||||
* testing (especially distro detection -> unit tests)
|
||||
|
||||
## Later
|
||||
|
||||
## Old
|
||||
|
||||
* handling of SIGTERM and SIGUSR
|
||||
* add support for RC/alpha/HEAD versions
|
||||
* check for updates on start
|
||||
|
||||
## Questions
|
||||
|
||||
* how to figure out tools (currently not done, but when setting ghc symlinks, removes all previous tools before symlinking requested version to avoid stale tools that only exist for one version)
|
||||
* handling of SIGTERM and SIGUSR
|
||||
* installing musl on demand?
|
||||
* redo/rethink how tool tags works
|
||||
* mirror support
|
||||
* checksums
|
||||
* check for new version on start
|
||||
* tarball tags as well as version tags?
|
||||
|
||||
* installing multiple versions in parallel?
|
||||
* how to version and extend the format of the downloads file? Compatibility?
|
||||
* how to propagate updates? Automatically? Might solve the versioning problem
|
||||
* installing musl on demand?
|
||||
* interactive handling when distro doesn't exist and we know the tarball is incompatible?
|
||||
* ghcup-with wrapper to execute a command with a given ghc in PATH?
|
||||
|
||||
* maybe add deprecation notice into JSON
|
||||
|
||||
@ -1,24 +1,20 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module AvailableDownloads where
|
||||
module BinaryDownloads where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Data.String.QQ
|
||||
import HPath
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
-- TODO: version quasiquoter
|
||||
availableDownloads :: AvailableDownloads
|
||||
availableDownloads = M.fromList
|
||||
binaryDownloads :: BinaryDownloads
|
||||
binaryDownloads = M.fromList
|
||||
[ ( GHC
|
||||
, M.fromList
|
||||
[ ( [vver|8.6.5|]
|
||||
@ -31,6 +27,7 @@ availableDownloads = M.fromList
|
||||
, 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))
|
||||
[s|5f871a3eaf808acb2420fdeef9318698|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -38,8 +35,9 @@ availableDownloads = M.fromList
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
|
||||
[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))
|
||||
[s|5f871a3eaf808acb2420fdeef9318698|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -49,11 +47,13 @@ availableDownloads = M.fromList
|
||||
, 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))
|
||||
[s|5f871a3eaf808acb2420fdeef9318698|]
|
||||
)
|
||||
, ( Just $ [vers|8|]
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
|
||||
[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))
|
||||
[s|5f871a3eaf808acb2420fdeef9318698|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -62,7 +62,7 @@ availableDownloads = M.fromList
|
||||
]
|
||||
),
|
||||
( [vver|8.4.4|]
|
||||
, VersionInfo [Latest] $ M.fromList
|
||||
, VersionInfo [] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
@ -71,6 +71,7 @@ availableDownloads = M.fromList
|
||||
, 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))
|
||||
[s|86785f41d228168461859e40956973fb|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -78,8 +79,9 @@ availableDownloads = M.fromList
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
|
||||
[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))
|
||||
[s|f943a245c54c2f2dcb354dceeff886e1|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -89,11 +91,13 @@ availableDownloads = M.fromList
|
||||
, 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))
|
||||
[s|f943a245c54c2f2dcb354dceeff886e1|]
|
||||
)
|
||||
, ( 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))
|
||||
[s|f943a245c54c2f2dcb354dceeff886e1|]
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -115,6 +119,7 @@ availableDownloads = M.fromList
|
||||
, 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
|
||||
[s|32352d2259909970e6ff04faf61bbfac|]
|
||||
)
|
||||
]
|
||||
)
|
||||
11
app/ghcup-gen/GHCupDownloads.hs
Normal file
11
app/ghcup-gen/GHCupDownloads.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module GHCupDownloads where
|
||||
|
||||
import GHCup.Types
|
||||
import BinaryDownloads
|
||||
import SourceDownloads
|
||||
|
||||
|
||||
ghcupDownloads :: GHCupDownloads
|
||||
ghcupDownloads = GHCupDownloads { _binaryDownloads = binaryDownloads
|
||||
, _sourceDownloads = sourceDownloads
|
||||
}
|
||||
@ -8,19 +8,21 @@
|
||||
|
||||
module Main where
|
||||
|
||||
import AvailableDownloads
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Logger
|
||||
import GHCupDownloads
|
||||
|
||||
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 GHCup.Logger
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
import System.IO ( stdout )
|
||||
import Validate
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
||||
data Options = Options
|
||||
@ -120,7 +122,7 @@ main = do
|
||||
GenJSON gopts -> do
|
||||
let
|
||||
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
|
||||
availableDownloads
|
||||
ghcupDownloads
|
||||
case gopts of
|
||||
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
|
||||
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
|
||||
@ -140,4 +142,4 @@ main = do
|
||||
av <- case eitherDecode contents of
|
||||
Right r -> pure r
|
||||
Left e -> die (color Red $ show e)
|
||||
myLoggerTStdout (validate av) >>= exitWith
|
||||
myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith
|
||||
|
||||
26
app/ghcup-gen/SourceDownloads.hs
Normal file
26
app/ghcup-gen/SourceDownloads.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module SourceDownloads where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Data.String.QQ
|
||||
import HPath
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
-- TODO: source tarballs
|
||||
-- TODO: reference tarballs
|
||||
sourceDownloads :: SourceDownloads
|
||||
sourceDownloads = M.fromList
|
||||
[ ( [vver|8.6.5|]
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
[s|b47726aaf302eb87b4970fcee924d45d|]
|
||||
)
|
||||
]
|
||||
@ -34,20 +34,23 @@ instance Exception ValidationError
|
||||
|
||||
-- TODO: test that GHC is in semver
|
||||
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
|
||||
=> AvailableDownloads
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validate av = do
|
||||
validate GHCupDownloads{..} = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
-- * verify binary downloads * --
|
||||
flip runReaderT ref $ do
|
||||
-- unique tags
|
||||
forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
|
||||
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t
|
||||
|
||||
-- required platforms
|
||||
forM_ (M.toList av) $ \(t, versions) ->
|
||||
forM_ (M.toList _binaryDownloads) $ \(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
|
||||
@ -65,7 +68,7 @@ validate av = do
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions av tool
|
||||
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
|
||||
@ -9,10 +9,13 @@
|
||||
module Main where
|
||||
|
||||
import GHCup
|
||||
import GHCup.File
|
||||
import GHCup.Logger
|
||||
import GHCup.Prelude
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
@ -25,16 +28,19 @@ import Data.String.Interpolate
|
||||
import Data.String.QQ
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import Options.Applicative hiding ( style )
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import Text.Read
|
||||
import Text.Layout.Table
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
@ -56,6 +62,7 @@ data Command
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
| DInfo
|
||||
| Compile CompileOptions
|
||||
|
||||
data ToolVersion = ToolVersion Version
|
||||
| ToolTag Tag
|
||||
@ -82,6 +89,14 @@ data RmOptions = RmOptions
|
||||
}
|
||||
|
||||
|
||||
data CompileOptions = CompileOptions
|
||||
{ ghcVer :: Version
|
||||
, bootstrapVer :: Version
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
}
|
||||
|
||||
|
||||
opts :: Parser Options
|
||||
opts =
|
||||
Options
|
||||
@ -139,6 +154,13 @@ com =
|
||||
(progDesc "Remove a GHC version installed by ghcup")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileOpts <**> helper)
|
||||
(progDesc "Compile GHC from source")
|
||||
)
|
||||
)
|
||||
<> commandGroup "GHC commands:"
|
||||
<> hidden
|
||||
)
|
||||
@ -195,17 +217,50 @@ listOpts =
|
||||
)
|
||||
|
||||
rmOpts :: Parser RmOptions
|
||||
rmOpts =
|
||||
RmOptions
|
||||
rmOpts = RmOptions <$> versionParser
|
||||
|
||||
|
||||
compileOpts :: Parser CompileOptions
|
||||
compileOpts =
|
||||
CompileOptions
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to remove"
|
||||
"The GHC version to compile"
|
||||
)
|
||||
)
|
||||
<*> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
( short 'b'
|
||||
<> long "bootstrap-version"
|
||||
<> metavar "BOOTSTRAP_VERSION"
|
||||
<> help "The GHC version to bootstrap with (must be installed)"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader (readEither @Int))
|
||||
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
|
||||
"How many jobs to use for make"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 'c' <> long "config" <> metavar "CONFIG" <> help
|
||||
"Absolute path to build config file"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
versionParser :: Parser Version
|
||||
@ -285,6 +340,7 @@ main = do
|
||||
, ProcessError
|
||||
, TagNotFound
|
||||
, URLException
|
||||
, DigestError
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
@ -313,13 +369,31 @@ main = do
|
||||
. runE
|
||||
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
let runCompileGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, NotInstalled
|
||||
, GHCNotFound
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, DigestError
|
||||
, BuildConfigNotFound
|
||||
, FileDoesNotExistError
|
||||
, URLException
|
||||
, JSONError
|
||||
]
|
||||
|
||||
case optCommand of
|
||||
Install (InstallGHC InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
av <- liftE getDownloads
|
||||
v <- liftE $ fromVersion av instVer GHC
|
||||
liftE $ installTool (ToolRequest GHC v) Nothing
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installTool dls (ToolRequest GHC v) Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
@ -329,12 +403,12 @@ main = do
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
Install (InstallGHC InstallOptions {..}) ->
|
||||
Install (InstallCabal InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
av <- liftE getDownloads
|
||||
v <- liftE $ fromVersion av instVer Cabal
|
||||
liftE $ installTool (ToolRequest Cabal v) Nothing
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installTool dls (ToolRequest Cabal v) Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
@ -348,8 +422,8 @@ main = do
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
av <- liftE getDownloads
|
||||
v <- liftE $ fromVersion av ghcVer GHC
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
@ -361,7 +435,8 @@ main = do
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
$ (runListGHC $ do
|
||||
liftE $ listVersions lTool lCriteria
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
liftIO $ listVersions dls lTool lCriteria
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> liftIO $ printListResult r
|
||||
@ -387,11 +462,28 @@ main = do
|
||||
VRight dinfo -> putStrLn $ show dinfo
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Compile (CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileGHC $ do
|
||||
dls <- _sourceDownloads <$> liftE getDownloads
|
||||
liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|GHC successfully compiled and installed|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
fromVersion :: Monad m
|
||||
=> AvailableDownloads
|
||||
=> BinaryDownloads
|
||||
-> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound] m Version
|
||||
|
||||
20
ghcup.cabal
20
ghcup.cabal
@ -33,6 +33,7 @@ common containers { build-depends: containers >= 0.6 }
|
||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
|
||||
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
|
||||
common hopenssl { build-depends: hopenssl >= 2.2.4 }
|
||||
common hpath { build-depends: hpath >= 0.11 }
|
||||
common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
|
||||
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
|
||||
@ -53,6 +54,7 @@ common resourcet { build-depends: resourcet >= 1.2.2 }
|
||||
common safe { build-depends: safe >= 0.3.18 }
|
||||
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
||||
common streamly { build-depends: streamly >= 0.7 }
|
||||
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
|
||||
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
|
||||
common strict-base { build-depends: strict-base >= 0.4 }
|
||||
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
|
||||
@ -101,6 +103,7 @@ library
|
||||
, generics-sop
|
||||
, haskus-utils-types
|
||||
, haskus-utils-variant
|
||||
, hopenssl
|
||||
, hpath
|
||||
, hpath-directory
|
||||
, hpath-filepath
|
||||
@ -120,6 +123,7 @@ library
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, streamly
|
||||
, streamly-posix
|
||||
, streamly-bytestring
|
||||
, strict-base
|
||||
, string-interpolate
|
||||
@ -138,13 +142,17 @@ library
|
||||
, word8
|
||||
, zlib
|
||||
exposed-modules: GHCup
|
||||
GHCup.Bash
|
||||
GHCup.File
|
||||
GHCup.Logger
|
||||
GHCup.Prelude
|
||||
GHCup.Download
|
||||
GHCup.Errors
|
||||
GHCup.Platform
|
||||
GHCup.Types
|
||||
GHCup.Types.JSON
|
||||
GHCup.Types.Optics
|
||||
GHCup.Utils
|
||||
GHCup.Utils.Bash
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.Logger
|
||||
GHCup.Utils.Prelude
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
hs-source-dirs: lib
|
||||
@ -201,7 +209,9 @@ executable ghcup-gen
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
main-is: Main.hs
|
||||
other-modules: AvailableDownloads
|
||||
other-modules: BinaryDownloads
|
||||
GHCupDownloads
|
||||
SourceDownloads
|
||||
Validate
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
|
||||
832
lib/GHCup.hs
832
lib/GHCup.hs
@ -12,12 +12,15 @@
|
||||
module GHCup where
|
||||
|
||||
|
||||
import GHCup.Bash
|
||||
import GHCup.File
|
||||
import GHCup.Prelude
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
@ -28,510 +31,32 @@ import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.Foldable
|
||||
import Data.IORef
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.String.QQ
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import Safe
|
||||
import System.IO.Error
|
||||
import System.Info
|
||||
import System.Posix.Env.ByteString ( getEnv )
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
import System.Posix.FilePath ( getSearchPath )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import System.Posix.Types
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
import qualified System.IO.Streams as Streams
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
}
|
||||
deriving Show
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
|
||||
|
||||
---------------------------
|
||||
--[ Excepts Error types ]--
|
||||
---------------------------
|
||||
|
||||
|
||||
data PlatformResultError = NoCompatiblePlatform String
|
||||
deriving Show
|
||||
|
||||
data NoDownload = NoDownload
|
||||
deriving Show
|
||||
|
||||
data NoCompatibleArch = NoCompatibleArch String
|
||||
deriving Show
|
||||
|
||||
data DistroNotFound = DistroNotFound
|
||||
deriving Show
|
||||
|
||||
data ArchiveError = UnknownArchive ByteString
|
||||
deriving Show
|
||||
|
||||
data URLException = UnsupportedURL
|
||||
deriving Show
|
||||
|
||||
data FileError = CopyError String
|
||||
deriving Show
|
||||
|
||||
data TagNotFound = TagNotFound Tag Tool
|
||||
deriving Show
|
||||
|
||||
data AlreadyInstalled = AlreadyInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
data NotInstalled = NotInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
data NotSet = NotSet Tool
|
||||
deriving Show
|
||||
|
||||
data JSONError = JSONDecodeError String
|
||||
deriving Show
|
||||
|
||||
data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
instance Exception ParseError
|
||||
|
||||
|
||||
|
||||
--------------------------------
|
||||
--[ AvailableDownloads stuff ]--
|
||||
--------------------------------
|
||||
|
||||
|
||||
ghcupURL :: URI
|
||||
ghcupURL =
|
||||
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
|
||||
|
||||
|
||||
-- | Get the tool versions that have this tag.
|
||||
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
|
||||
getTagged av tool tag = toListOf
|
||||
( ix tool
|
||||
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
% to Map.keys
|
||||
% folded
|
||||
)
|
||||
av
|
||||
|
||||
getLatest :: AvailableDownloads -> Tool -> Maybe Version
|
||||
getLatest av tool = headOf folded $ getTagged av tool Latest
|
||||
|
||||
getRecommended :: AvailableDownloads -> Tool -> Maybe Version
|
||||
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
|
||||
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> Excepts
|
||||
'[FileDoesNotExistError , URLException , JSONError]
|
||||
m
|
||||
AvailableDownloads
|
||||
getDownloads = lift getUrlSource >>= \case
|
||||
GHCupURL -> do
|
||||
bs <- liftE $ downloadBS ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- liftE $ downloadBS url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
|
||||
|
||||
----------------------
|
||||
--[ Download stuff ]--
|
||||
----------------------
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> ToolRequest
|
||||
-> Maybe PlatformRequest
|
||||
-> Excepts
|
||||
'[ DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, PlatformResultError
|
||||
, URLException
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo (ToolRequest t v) mpfReq = do
|
||||
urlSource <- lift getUrlSource
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
-- lift $ monadLoggerLog undefined undefined undefined ""
|
||||
(PlatformRequest arch' plat ver) <- case mpfReq of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
ar <- lE getArchitecture
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
dls <- liftE $ getDownloads
|
||||
|
||||
lE $ getDownloadInfo' t v arch' plat ver dls
|
||||
|
||||
|
||||
getDownloadInfo' :: Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> Architecture
|
||||
-- ^ user arch
|
||||
-> Platform
|
||||
-- ^ user platform
|
||||
-> Maybe Versioning
|
||||
-- ^ optional version of the platform
|
||||
-> AvailableDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo' t v a p mv dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
||||
|
||||
|
||||
-- | Same as `download'`, except uses URL type. As such, this might
|
||||
-- throw an exception if the url type or host protocol is not supported.
|
||||
--
|
||||
-- Only Absolute HTTP/HTTPS is supported.
|
||||
download :: (MonadLogger m, MonadIO m)
|
||||
=> DownloadInfo
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[URLException] m (Path Abs)
|
||||
download dli dest mfn
|
||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
|
||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
|
||||
| otherwise = throwE UnsupportedURL
|
||||
|
||||
where
|
||||
dl https = do
|
||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
host <-
|
||||
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
||||
?? UnsupportedURL
|
||||
let path = view (dlUri % pathL') dli
|
||||
let port = preview
|
||||
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
||||
dli
|
||||
liftIO $ download' https host path port dest mfn
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError , URLException]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
= liftException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
|
||||
| otherwise
|
||||
= throwE UnsupportedURL
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
host <-
|
||||
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
|
||||
?? UnsupportedURL
|
||||
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
|
||||
-- Manage to find a file we can write the body into.
|
||||
getFile :: IO (Fd, Path Abs)
|
||||
getFile = do
|
||||
-- destination dir must exist
|
||||
hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
case mfn of
|
||||
-- if a filename was provided, try that
|
||||
Just x ->
|
||||
let fp = dest </> x
|
||||
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
||||
Nothing -> do
|
||||
-- ...otherwise try to infer the filename from the URL path
|
||||
fn' <- urlBaseName path
|
||||
let fp = dest </> fn'
|
||||
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
|
||||
(\_ i' -> do
|
||||
outStream <- Streams.makeOutputStream
|
||||
(\case
|
||||
Just bs -> void $ consumer bs
|
||||
Nothing -> pure ()
|
||||
)
|
||||
Streams.connect i' outStream
|
||||
)
|
||||
|
||||
closeConnection c
|
||||
|
||||
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
--------------------------
|
||||
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
"i386" -> Right A_32
|
||||
what -> Left (NoCompatibleArch what)
|
||||
|
||||
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
pfr <- case os of
|
||||
"linux" -> do
|
||||
(distro, ver) <- liftE getLinuxDistro
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
-- TODO: these are not verified
|
||||
"darwin" ->
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
|
||||
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
||||
getLinuxDistro = do
|
||||
-- TODO: don't do alternative on IO, because it hides bugs
|
||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||
[ try_os_release
|
||||
, try_lsb_release_cmd
|
||||
, try_lsb_release
|
||||
, try_redhat_release
|
||||
, try_debian_version
|
||||
]
|
||||
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
||||
distro = if
|
||||
| hasWord name ["debian"] -> Debian
|
||||
| hasWord name ["ubuntu"] -> Ubuntu
|
||||
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
||||
| hasWord name ["fedora"] -> Fedora
|
||||
| hasWord name ["centos"] -> CentOS
|
||||
| hasWord name ["Red Hat"] -> RedHat
|
||||
| hasWord name ["alpine"] -> Alpine
|
||||
| hasWord name ["exherbo"] -> Exherbo
|
||||
| hasWord name ["gentoo"] -> Gentoo
|
||||
| otherwise -> UnknownLinux
|
||||
pure (distro, parsedVer)
|
||||
where
|
||||
hasWord t matches = foldr
|
||||
(\x y ->
|
||||
( isJust
|
||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
|
||||
$ t
|
||||
)
|
||||
|| y
|
||||
)
|
||||
False
|
||||
(T.pack <$> matches)
|
||||
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
lsb_release :: Path Abs
|
||||
lsb_release = [abs|/etc/lsb-release|]
|
||||
lsb_release_cmd :: Path Rel
|
||||
lsb_release_cmd = [rel|lsb-release|]
|
||||
redhat_release :: Path Abs
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||
try_lsb_release_cmd = do
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
try_lsb_release = do
|
||||
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
||||
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- fmap lBS2sT $ readFile redhat_release
|
||||
let nameRe n =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
|
||||
$ t
|
||||
verRe =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
|
||||
$ t
|
||||
(Just name) <- pure
|
||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||
pure (name, verRe)
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just $ lBS2sT ver)
|
||||
|
||||
|
||||
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
||||
-- parseAvailableDownloads = undefined
|
||||
|
||||
|
||||
|
||||
@ -554,7 +79,8 @@ installTool :: ( MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadResource m
|
||||
) -- tmp file
|
||||
=> ToolRequest
|
||||
=> BinaryDownloads
|
||||
-> ToolRequest
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
@ -569,10 +95,11 @@ installTool :: ( MonadThrow m
|
||||
, PlatformResultError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, DigestError
|
||||
]
|
||||
m
|
||||
()
|
||||
installTool treq mpfReq = do
|
||||
installTool bDls treq mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install: #{treq}|]
|
||||
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
|
||||
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
|
||||
@ -580,39 +107,24 @@ installTool treq mpfReq = do
|
||||
Settings {..} <- lift ask
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo treq mpfReq
|
||||
dl <- case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
fn <- urlBaseName $ view (dlUri % pathL') dlinfo
|
||||
let cachfile = cachedir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> pure $ cachfile
|
||||
| otherwise -> liftE $ download dlinfo cachedir Nothing
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dlinfo tmp Nothing
|
||||
dlinfo <- liftE $ getDownloadInfo bDls treq mpfReq
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
unpacked <- liftE $ unpackToTmpDir dl
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
case treq of
|
||||
(ToolRequest GHC ver) -> do
|
||||
liftE $ installGHC archiveSubdir ghcdir
|
||||
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)
|
||||
liftE $ postGHCInstall ver
|
||||
(ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
@ -632,10 +144,11 @@ installGHC :: (MonadLogger m, MonadIO m)
|
||||
installGHC path inst = do
|
||||
lift $ $(logInfo) [s|Installing GHC|]
|
||||
lEM $ liftIO $ exec [s|./configure|]
|
||||
[[s|--prefix=|] <> toFilePath inst]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath inst]
|
||||
(Just path)
|
||||
lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path)
|
||||
Nothing
|
||||
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
|
||||
pure ()
|
||||
|
||||
|
||||
@ -679,13 +192,15 @@ setGHC ver sghc = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- symlink destination
|
||||
destdir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms destdir
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
|
||||
when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
forM_ verfiles $ \file -> do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
|
||||
targetFile <- case sghc of
|
||||
SetGHCOnly -> pure file
|
||||
SetGHCMajor -> do
|
||||
@ -695,8 +210,8 @@ setGHC ver sghc = do
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
(destdir </> targetFile)
|
||||
liftIO $ createSymlink (destdir </> targetFile)
|
||||
(bindir </> targetFile)
|
||||
liftIO $ createSymlink (bindir </> targetFile)
|
||||
(ghcLinkDestination (toFilePath file) ver)
|
||||
|
||||
-- create symlink for share dir
|
||||
@ -721,6 +236,18 @@ setGHC ver sghc = do
|
||||
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
|
||||
_ -> pure ()
|
||||
|
||||
-- The old tool symlinks might be different (e.g. more) than the
|
||||
-- requested version. Have to avoid "stray" symlinks.
|
||||
delOldSymlinks :: forall m
|
||||
. (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> Excepts '[] m ()
|
||||
delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
|
||||
mv <- ghcSet
|
||||
for_ mv $ \ver' -> do
|
||||
verfiles <- ghcToolFiles ver'
|
||||
for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -743,34 +270,22 @@ data ListResult = ListResult
|
||||
deriving Show
|
||||
|
||||
|
||||
availableToolVersions :: AvailableDownloads -> Tool -> [(Version, [Tag])]
|
||||
availableToolVersions :: BinaryDownloads -> 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, MonadCatch m)
|
||||
=> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError , URLException , JSONError]
|
||||
m
|
||||
[ListResult]
|
||||
listVersions lt criteria = do
|
||||
dls <- liftE $ getDownloads
|
||||
liftIO $ listVersions' dls lt criteria
|
||||
|
||||
|
||||
listVersions' :: AvailableDownloads
|
||||
listVersions :: BinaryDownloads
|
||||
-> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> IO [ListResult]
|
||||
listVersions' av lt criteria = case lt of
|
||||
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
|
||||
ghcvers <- listVersions av (Just GHC) criteria
|
||||
cabalvers <- listVersions av (Just Cabal) criteria
|
||||
pure (ghcvers <> cabalvers)
|
||||
|
||||
where
|
||||
@ -897,167 +412,116 @@ getDebugInfo = do
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
---------------
|
||||
--[ Compile ]--
|
||||
---------------
|
||||
|
||||
|
||||
ghcupBaseDir :: IO (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
||||
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
||||
|
||||
ghcupGHCDir :: Version -> IO (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel (verToBS ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
|
||||
|
||||
-- | Extract the version part of the result of `ghcLinkDestination`.
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
||||
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
||||
where
|
||||
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
ghcInstalled :: Version -> IO Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
cabalInstalled ver = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
|
||||
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
pure (reportedVer == (verToBS ver))
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
-- | We assume GHC is in semver format. I hope it is.
|
||||
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
|
||||
getGHCMajor ver = do
|
||||
SemVer {..} <- throwEither (semver $ prettyVer ver)
|
||||
pure (fromIntegral _svMajor, fromIntegral _svMinor)
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
mapM (throwEither . version)
|
||||
. fmap prettySemVer
|
||||
. lastMay
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
-- TODO: build config
|
||||
compileGHC :: ( MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
$ semvers
|
||||
=> SourceDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, NotInstalled
|
||||
, GHCNotFound
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, DigestError
|
||||
, BuildConfigNotFound
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bver jobs mbuildConfig = do
|
||||
let treq = ToolRequest GHC tver
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
||||
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
|
||||
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix tver) dls ?? GHCNotFound
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
|
||||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToTmpDir :: (MonadResource m -- temp file
|
||||
, MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ archive path
|
||||
-> Excepts '[ArchiveError] m (Path Abs)
|
||||
unpackToTmpDir av = do
|
||||
let fp = E.decodeUtf8 (toFilePath av)
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
tmp <- toFilePath <$> lift withGHCupTmpDir
|
||||
let untar bs = do
|
||||
Tar.unpack tmp . Tar.read $ bs
|
||||
parseAbs tmp
|
||||
|
||||
-- extract, depending on file extension
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
| tver >= [vver|8.8.0|] -> do
|
||||
cEnv <- liftIO $ getEnvironment
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
|
||||
let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
|
||||
lEM $ liftIO $ exec [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath ghcdir]
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
| otherwise -> do
|
||||
lEM $ liftIO $ exec
|
||||
[s|./configure|]
|
||||
False
|
||||
[ [s|--prefix=|] <> toFilePath ghcdir
|
||||
, [s|--with-ghc=|] <> toFilePath bghc
|
||||
]
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIO $ copyFile bc build_mk Overwrite
|
||||
Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf
|
||||
|
||||
lEM $ liftIO $ exec [s|make|]
|
||||
True
|
||||
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing
|
||||
|
||||
liftE $ postGHCInstall tver
|
||||
pure ()
|
||||
|
||||
where
|
||||
defaultConf = [s|
|
||||
V=0
|
||||
BUILD_MAN = NO
|
||||
BUILD_SPHINX_HTML = NO
|
||||
BUILD_SPHINX_PDF = NO
|
||||
HADDOCK_DOCS = YES
|
||||
GhcWithLlvmCodeGen = YES|]
|
||||
|
||||
|
||||
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
|
||||
-- while ignoring *-<ver> symlinks
|
||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
-- | Creates ghc-x.y.z and ghc-x.y symlinks.
|
||||
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
postGHCInstall ver = do
|
||||
liftE $ setGHC ver SetGHCMinor
|
||||
|
||||
-- fail if ghc is not installed
|
||||
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
|
||||
-- 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)
|
||||
|
||||
337
lib/GHCup/Download.hs
Normal file
337
lib/GHCup/Download.hs
Normal file
@ -0,0 +1,337 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
module GHCup.Download where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.String.QQ
|
||||
import Data.Versions
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import OpenSSL.Digest
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import System.Posix.Types
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.IO.Streams as Streams
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
|
||||
|
||||
|
||||
ghcupURL :: URI
|
||||
ghcupURL =
|
||||
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
|
||||
|
||||
|
||||
|
||||
-- | Downloads the download information!
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Excepts
|
||||
'[FileDoesNotExistError , URLException , JSONError]
|
||||
m
|
||||
GHCupDownloads
|
||||
getDownloads = do
|
||||
urlSource <- lift getUrlSource
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- liftE $ downloadBS ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- liftE $ downloadBS url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> BinaryDownloads
|
||||
-> ToolRequest
|
||||
-> Maybe PlatformRequest
|
||||
-> Excepts
|
||||
'[ DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, PlatformResultError
|
||||
, URLException
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo bDls (ToolRequest t v) mpfReq = do
|
||||
(PlatformRequest arch' plat ver) <- case mpfReq of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
ar <- lE getArchitecture
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
lE $ getDownloadInfo' t v arch' plat ver bDls
|
||||
|
||||
|
||||
getDownloadInfo' :: Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> Architecture
|
||||
-- ^ user arch
|
||||
-> Platform
|
||||
-- ^ user platform
|
||||
-> Maybe Versioning
|
||||
-- ^ optional version of the platform
|
||||
-> BinaryDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo' t v a p mv dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
||||
|
||||
|
||||
-- | Same as `download'`, except uses URL type. As such, this might
|
||||
-- throw an exception if the url type or host protocol is not supported.
|
||||
--
|
||||
-- Only Absolute HTTP/HTTPS is supported.
|
||||
download :: (MonadLogger m, MonadIO m)
|
||||
=> DownloadInfo
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , URLException] m (Path Abs)
|
||||
download dli dest mfn
|
||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
|
||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
|
||||
| otherwise = throwE UnsupportedURL
|
||||
|
||||
where
|
||||
dl https = do
|
||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
host <-
|
||||
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
||||
?? UnsupportedURL
|
||||
let path = view (dlUri % pathL') dli
|
||||
let port = preview
|
||||
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
||||
dli
|
||||
p <- liftIO $ download' https host path port dest mfn
|
||||
-- TODO: verify md5 during download
|
||||
let p' = toFilePath p
|
||||
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
||||
c <- liftIO $ readFile p
|
||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
|
||||
eDigest = view dlHash dli
|
||||
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
|
||||
pure p
|
||||
|
||||
|
||||
-- | Download or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
downloadCached :: ( MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , URLException] m (Path Abs)
|
||||
downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cachedir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists
|
||||
-> do
|
||||
let cachfile' = toFilePath cachfile
|
||||
lift $ $(logInfo) [i|veryfing digest of: #{cachfile'}|]
|
||||
c <- liftIO $ readFile cachfile
|
||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
|
||||
eDigest = view dlHash dli
|
||||
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
|
||||
pure $ cachfile
|
||||
| otherwise
|
||||
-> liftE $ download dli cachedir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError , URLException]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
= liftException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
|
||||
| otherwise
|
||||
= throwE UnsupportedURL
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
host <-
|
||||
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
|
||||
?? UnsupportedURL
|
||||
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
|
||||
-- Manage to find a file we can write the body into.
|
||||
getFile :: IO (Fd, Path Abs)
|
||||
getFile = do
|
||||
-- destination dir must exist
|
||||
hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
case mfn of
|
||||
-- if a filename was provided, try that
|
||||
Just x ->
|
||||
let fp = dest </> x
|
||||
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
||||
Nothing -> do
|
||||
-- ...otherwise try to infer the filename from the URL path
|
||||
fn' <- urlBaseName path
|
||||
let fp = dest </> fn'
|
||||
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
|
||||
(\_ i' -> do
|
||||
outStream <- Streams.makeOutputStream
|
||||
(\case
|
||||
Just bs -> void $ consumer bs
|
||||
Nothing -> pure ()
|
||||
)
|
||||
Streams.connect i' outStream
|
||||
)
|
||||
|
||||
closeConnection c
|
||||
|
||||
63
lib/GHCup/Errors.hs
Normal file
63
lib/GHCup/Errors.hs
Normal file
@ -0,0 +1,63 @@
|
||||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Text ( Text )
|
||||
import HPath
|
||||
|
||||
|
||||
-- | A compatible platform could not be found.
|
||||
data PlatformResultError = NoCompatiblePlatform String -- the platform we got
|
||||
deriving Show
|
||||
|
||||
data NoDownload = NoDownload
|
||||
deriving Show
|
||||
|
||||
data NoCompatibleArch = NoCompatibleArch String
|
||||
deriving Show
|
||||
|
||||
data DistroNotFound = DistroNotFound
|
||||
deriving Show
|
||||
|
||||
data ArchiveError = UnknownArchive ByteString
|
||||
deriving Show
|
||||
|
||||
data URLException = UnsupportedURL
|
||||
deriving Show
|
||||
|
||||
data FileError = CopyError String
|
||||
deriving Show
|
||||
|
||||
data TagNotFound = TagNotFound Tag Tool
|
||||
deriving Show
|
||||
|
||||
data AlreadyInstalled = AlreadyInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
data NotInstalled = NotInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
data NotSet = NotSet Tool
|
||||
deriving Show
|
||||
|
||||
data JSONError = JSONDecodeError String
|
||||
deriving Show
|
||||
|
||||
data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ParseError
|
||||
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
data GHCNotFound = GHCNotFound
|
||||
deriving Show
|
||||
|
||||
data BuildConfigNotFound = BuildConfigNotFound (Path Abs)
|
||||
deriving Show
|
||||
|
||||
data DigestError = DigestError Text Text
|
||||
deriving Show
|
||||
165
lib/GHCup/Platform.hs
Normal file
165
lib/GHCup/Platform.hs
Normal file
@ -0,0 +1,165 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Platform where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Bash
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.String.QQ
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
--------------------------
|
||||
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
"i386" -> Right A_32
|
||||
what -> Left (NoCompatibleArch what)
|
||||
|
||||
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
pfr <- case os of
|
||||
"linux" -> do
|
||||
(distro, ver) <- liftE getLinuxDistro
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
-- TODO: these are not verified
|
||||
"darwin" ->
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
|
||||
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
||||
getLinuxDistro = do
|
||||
-- TODO: don't do alternative on IO, because it hides bugs
|
||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||
[ try_os_release
|
||||
, try_lsb_release_cmd
|
||||
, try_lsb_release
|
||||
, try_redhat_release
|
||||
, try_debian_version
|
||||
]
|
||||
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
||||
distro = if
|
||||
| hasWord name ["debian"] -> Debian
|
||||
| hasWord name ["ubuntu"] -> Ubuntu
|
||||
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
||||
| hasWord name ["fedora"] -> Fedora
|
||||
| hasWord name ["centos"] -> CentOS
|
||||
| hasWord name ["Red Hat"] -> RedHat
|
||||
| hasWord name ["alpine"] -> Alpine
|
||||
| hasWord name ["exherbo"] -> Exherbo
|
||||
| hasWord name ["gentoo"] -> Gentoo
|
||||
| otherwise -> UnknownLinux
|
||||
pure (distro, parsedVer)
|
||||
where
|
||||
hasWord t matches = foldr
|
||||
(\x y ->
|
||||
( isJust
|
||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
|
||||
$ t
|
||||
)
|
||||
|| y
|
||||
)
|
||||
False
|
||||
(T.pack <$> matches)
|
||||
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
lsb_release :: Path Abs
|
||||
lsb_release = [abs|/etc/lsb-release|]
|
||||
lsb_release_cmd :: Path Rel
|
||||
lsb_release_cmd = [rel|lsb-release|]
|
||||
redhat_release :: Path Abs
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||
try_lsb_release_cmd = do
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
try_lsb_release = do
|
||||
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
||||
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- fmap lBS2sT $ readFile redhat_release
|
||||
let nameRe n =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
|
||||
$ t
|
||||
verRe =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
|
||||
$ t
|
||||
(Just name) <- pure
|
||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||
pure (name, verRe)
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just $ lBS2sT ver)
|
||||
@ -3,6 +3,7 @@
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
@ -10,6 +11,14 @@ import URI.ByteString
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
@ -25,7 +34,7 @@ data DebugInfo = DebugInfo
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHCMajor -- ^ ghc-x.y
|
||||
| SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
|
||||
deriving Show
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
data Tag = Latest
|
||||
@ -41,10 +50,12 @@ data VersionInfo = VersionInfo
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Tool = GHC
|
||||
| GHCSrc
|
||||
| Cabal
|
||||
| GHCUp
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
@ -98,10 +109,17 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type AvailableDownloads = Map Tool ToolVersionSpec
|
||||
type BinaryDownloads = Map Tool ToolVersionSpec
|
||||
|
||||
type SourceDownloads = Map Version DownloadInfo
|
||||
|
||||
data GHCupDownloads = GHCupDownloads {
|
||||
_binaryDownloads :: BinaryDownloads
|
||||
, _sourceDownloads :: SourceDownloads
|
||||
} deriving Show
|
||||
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec AvailableDownloads
|
||||
| OwnSpec GHCupDownloads
|
||||
deriving Show
|
||||
|
||||
|
||||
@ -41,6 +41,7 @@ deriveJSON defaultOptions ''VUnit
|
||||
deriveJSON defaultOptions ''VersionInfo
|
||||
deriveJSON defaultOptions ''Tag
|
||||
deriveJSON defaultOptions ''DownloadInfo
|
||||
deriveJSON defaultOptions ''GHCupDownloads
|
||||
|
||||
|
||||
instance ToJSON URI where
|
||||
|
||||
@ -19,6 +19,7 @@ makeLenses ''ToolRequest
|
||||
makeLenses ''DownloadInfo
|
||||
makeLenses ''Tag
|
||||
makeLenses ''VersionInfo
|
||||
makeLenses ''GHCupDownloads
|
||||
|
||||
|
||||
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
|
||||
|
||||
240
lib/GHCup/Utils.hs
Normal file
240
lib/GHCup/Utils.hs
Normal file
@ -0,0 +1,240 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Utils where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.String.QQ
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import Safe
|
||||
import System.Posix.Env.ByteString ( getEnv )
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
-----------------
|
||||
|
||||
|
||||
ghcupBaseDir :: IO (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
||||
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
||||
|
||||
ghcupGHCDir :: Version -> IO (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel (verToBS ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
|
||||
|
||||
-- | Extract the version part of the result of `ghcLinkDestination`.
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
||||
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
||||
where
|
||||
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
ghcInstalled :: Version -> IO Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
cabalInstalled ver = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
|
||||
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
pure (reportedVer == (verToBS ver))
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
-- | We assume GHC is in semver format. I hope it is.
|
||||
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
|
||||
getGHCMajor ver = do
|
||||
SemVer {..} <- throwEither (semver $ prettyVer ver)
|
||||
pure (fromIntegral _svMajor, fromIntegral _svMinor)
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
mapM (throwEither . version)
|
||||
. fmap prettySemVer
|
||||
. lastMay
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
)
|
||||
$ semvers
|
||||
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
-> Excepts '[ArchiveError] m ()
|
||||
unpackToDir dest av = do
|
||||
let fp = E.decodeUtf8 (toFilePath av)
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
-- 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
|
||||
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
|
||||
|
||||
|
||||
-- | Get the tool versions that have this tag.
|
||||
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
|
||||
getTagged av tool tag = toListOf
|
||||
( ix tool
|
||||
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
% to Map.keys
|
||||
% folded
|
||||
)
|
||||
av
|
||||
|
||||
getLatest :: BinaryDownloads -> Tool -> Maybe Version
|
||||
getLatest av tool = headOf folded $ getTagged av tool Latest
|
||||
|
||||
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
|
||||
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
@ -1,4 +1,4 @@
|
||||
module GHCup.Bash
|
||||
module GHCup.Utils.Bash
|
||||
( findAssignment
|
||||
, equalsAssignmentWith
|
||||
, getRValue
|
||||
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.File where
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
@ -16,13 +18,13 @@ import Data.Maybe
|
||||
import Data.String.QQ
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Posix.Directory.ByteString
|
||||
import System.Posix.Env.ByteString
|
||||
@ -40,6 +42,7 @@ import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import qualified System.Posix.User as PU
|
||||
import Streamly.External.Posix.DirStream
|
||||
import qualified Streamly.Internal.Memory.ArrayStream
|
||||
as AS
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
@ -163,15 +166,17 @@ createRegularFileFd fm dest =
|
||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: ByteString -- ^ thing to execute
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe args spath chdir = do
|
||||
exec exe spath args chdir env = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args Nothing
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
|
||||
|
||||
@ -192,7 +197,6 @@ mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||
liftIO $ System.IO.putStrLn $ show tmp
|
||||
parseAbs tmp
|
||||
|
||||
|
||||
@ -216,3 +220,25 @@ unsafePathToString :: Path b -> IO FilePath
|
||||
unsafePathToString (Path p) = do
|
||||
enc <- getLocaleEncoding
|
||||
unsafeUseAsCStringLen p (peekCStringLen enc)
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM PermissionDenied (go xs)
|
||||
$ hideErrorDefM NoSuchThing (go xs)
|
||||
$ do
|
||||
dirStream <- openDirStream (toFilePath x)
|
||||
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
|
||||
>>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == toFilePath needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
@ -1,4 +1,4 @@
|
||||
module GHCup.Logger where
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
|
||||
import Control.Monad.Logger
|
||||
@ -11,7 +11,7 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup.Prelude where
|
||||
module GHCup.Utils.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
@ -29,7 +29,9 @@ import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH.Syntax ( Exp(..) , Lift)
|
||||
import Language.Haskell.TH.Syntax ( Exp(..)
|
||||
, Lift
|
||||
)
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
@ -163,6 +165,16 @@ liftException errType ex =
|
||||
. liftE
|
||||
|
||||
|
||||
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
|
||||
hideErrorDef err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
|
||||
|
||||
|
||||
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
|
||||
hideErrorDefM err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
|
||||
|
||||
|
||||
-- TODO: does this work?
|
||||
hideExcept :: forall e es es' a m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
@ -173,6 +185,15 @@ hideExcept :: forall e es es' a m
|
||||
hideExcept _ a action =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
|
||||
|
||||
hideExcept' :: forall e es es' m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
hideExcept' _ action =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
|
||||
|
||||
|
||||
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
throwEither a = case a of
|
||||
Loading…
Reference in New Issue
Block a user