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

Lalalal

Browse Source
This commit is contained in:
Julian Ospald 2020-03-03 23:34:25 +01:00
parent 62b249db2d
commit 63f9bc6b0a
9 changed files with 292 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.md
View File

@ -5,9 +5,6 @@
* better logs
* better debug-output
* upgrade Upgrade this script in-place
* reference tarballs in json
## Maybe

179
app/ghcup-gen/BinaryDownloads.hs
View File

@ -13,6 +13,86 @@ import URI.ByteString.QQ
import qualified Data.Map as M
-----------------
--[ GHC 8.4.4 ]--
-----------------
ghc_844_64_fedora :: DownloadInfo
ghc_844_64_fedora = 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|5f871a3eaf808acb2420fdeef9318698|]
ghc_844_64_debian9 :: DownloadInfo
ghc_844_64_debian9 = 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))
[s|5f871a3eaf808acb2420fdeef9318698|]
ghc_844_64_debian8 :: DownloadInfo
ghc_844_64_debian8 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb8-linux.tar.xz|]
(Just ([rel|ghc-8.4.4|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
-----------------
--[ GHC 8.6.5 ]--
-----------------
ghc_865_64_fedora :: DownloadInfo
ghc_865_64_fedora = 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|]
ghc_865_64_debian9 :: DownloadInfo
ghc_865_64_debian9 = 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))
[s|8de779b73c1b2f1b7ab49030015fce3d|]
ghc_865_64_debian8 :: DownloadInfo
ghc_865_64_debian8 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|5f871a3eaf808acb2420fdeef9318698|]
---------------------
--[ Cabal-3.0.0.0 ]--
---------------------
cabal_3000_64_linux :: DownloadInfo
cabal_3000_64_linux = 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|]
-------------
--[ GHCup ]--
-------------
ghcup_010_64_linux :: DownloadInfo
ghcup_010_64_linux = DownloadInfo [uri|file:///home/ospa_ju/tmp/ghcup-exe|]
Nothing
[s|d8da9e09ca71648f4c1bc6a0a46efc82|]
-----------------------
--[ Tarball mapping ]--
-----------------------
binaryDownloads :: BinaryDownloads
binaryDownloads = M.fromList
[ ( GHC
@ -21,84 +101,28 @@ binaryDownloads = M.fromList
, 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))
[s|5f871a3eaf808acb2420fdeef9318698|]
)
]
)
, ( Linux Ubuntu
, 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))
[s|5f871a3eaf808acb2420fdeef9318698|]
)
]
)
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux Ubuntu , M.fromList [(Nothing, ghc_865_64_debian9)])
, ( 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))
[s|5f871a3eaf808acb2420fdeef9318698|]
)
, ( Just $ [vers|8|]
, 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|]
)
[ (Nothing , ghc_865_64_debian9)
, (Just $ [vers|8|], ghc_865_64_debian8)
]
)
]
)
]
),
( [vver|8.4.4|]
)
, ( [vver|8.4.4|]
, VersionInfo [] $ 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))
[s|86785f41d228168461859e40956973fb|]
)
]
)
, ( Linux Ubuntu
, 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))
[s|f943a245c54c2f2dcb354dceeff886e1|]
)
]
)
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)])
, (Linux Ubuntu , M.fromList [(Nothing, ghc_844_64_fedora)])
, ( 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))
[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|]
)
[ (Nothing , ghc_844_64_debian9)
, (Just $ [vers|8|], ghc_844_64_debian8)
]
)
]
@ -114,16 +138,21 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, cabal_3000_64_linux)]
)
]
)
]
)
]
)
, ( GHCup
, 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
[s|32352d2259909970e6ff04faf61bbfac|]
)
]
)
]
[ ( [vver|0.1.0|]
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
[(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]
)
]
)

1
app/ghcup-gen/Validate.hs
View File

@ -33,6 +33,7 @@ instance Exception ValidationError
-- TODO: test that GHC is in semver
-- TODO: check there's LATEST tag for every tool
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
=> GHCupDownloads
-> m ExitCode

82
app/ghcup/Main.hs
View File

@ -31,6 +31,7 @@ import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO
import Text.Read
@ -63,6 +64,7 @@ data Command
| Rm RmOptions
| DInfo
| Compile CompileOptions
| Upgrade UpgradeOpts
data ToolVersion = ToolVersion Version
| ToolTag Tag
@ -96,6 +98,11 @@ data CompileOptions = CompileOptions
, buildConfig :: Maybe (Path Abs)
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
deriving Show
opts :: Parser Options
opts =
@ -127,7 +134,9 @@ com =
( command
"install"
( Install
<$> (info (installP <**> helper) (progDesc "Install GHC or cabal"))
<$> (info (installP <**> helper)
(progDesc "Install or update GHC/cabal")
)
)
<> command
"list"
@ -136,6 +145,11 @@ com =
(progDesc "Show available GHCs and other tools")
)
)
<> command
"upgrade"
( Upgrade
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)"))
)
<> commandGroup "Main commands:"
)
<|> subparser
@ -309,6 +323,32 @@ toSettings Options {..} =
in Settings { .. }
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> (option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
)
<|> (pure UpgradeGHCupDir)
-- TODO: something better than Show instance for errors
main :: IO ()
@ -387,6 +427,22 @@ main = do
, JSONError
]
let runUpgrade =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ DigestError
, URLException
, DistroNotFound
, PlatformResultError
, NoCompatibleArch
, NoDownload
, FileDoesNotExistError
, JSONError
]
case optCommand of
Install (InstallGHC InstallOptions {..}) ->
void
@ -479,6 +535,30 @@ main = do
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Upgrade (uOpts) -> do
liftIO $ putStrLn $ show uOpts
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO $ getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
liftIO $ putStrLn "blah"
pure Nothing
void
$ (runUpgrade $ do
dls <- _binaryDownloads <$> liftE getDownloads
liftE $ upgradeGHCup dls target
)
>>= \case
VRight v' ->
runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{v'}|]
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
pure ()

1
ghcup.cabal
View File

@ -153,6 +153,7 @@ library
GHCup.Utils.File
GHCup.Utils.Logger
GHCup.Utils.Prelude
GHCup.Version
-- other-modules:
-- other-extensions:
hs-source-dirs: lib

49
lib/GHCup.hs
View File

@ -21,6 +21,7 @@ import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
import Control.Applicative
import Control.Exception.Safe
@ -101,8 +102,13 @@ installTool :: ( MonadThrow m
()
installTool bDls treq mpfReq = do
lift $ $(logDebug) [i|Requested to install: #{treq}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
-- stop if GHC is already installed, other tools can be overwritten
case treq of
(ToolRequest GHC _) ->
whenM (liftIO $ toolAlreadyInstalled treq)
$ (throwE $ AlreadyInstalled treq)
(ToolRequest Cabal _) -> pure ()
Settings {..} <- lift ask
@ -508,6 +514,45 @@ GhcWithLlvmCodeGen = YES|]
---------------
--[ Set GHC ]--
---------------
upgradeGHCup :: ( MonadReader Settings m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadResource m
, MonadIO m
)
=> BinaryDownloads
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Excepts
'[ DigestError
, URLException
, DistroNotFound
, PlatformResultError
, NoCompatibleArch
, NoDownload
]
m
Version
upgradeGHCup dls mtarget = do
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = head $ getTagged dls GHCup Latest
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn)
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir
liftIO $ copyFile p (dest </> fn) Overwrite
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
pure latestVer
-------------
--[ Other ]--

100
lib/GHCup/Download.hs
View File

@ -52,7 +52,6 @@ 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
@ -107,12 +106,9 @@ getDownloadInfo :: ( MonadLogger m
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, FileDoesNotExistError
, JSONError
, PlatformResultError
, NoCompatibleArch
, NoDownload
, PlatformResultError
, URLException
]
m
DownloadInfo
@ -152,43 +148,73 @@ getDownloadInfo' t v a p mv dls = maybe
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.
-- | 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
--
-- Only Absolute HTTP/HTTPS is supported.
download :: (MonadLogger m, MonadIO m)
-- The file must not exist.
download :: (MonadThrow m, 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
download dli dest mfn | scheme == [s|https|] = dl True
| scheme == [s|http|] = dl False
| scheme == [s|file|] = cp
| otherwise = throwE UnsupportedURL
where
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
cp = do
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
pure destFile
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
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
-- download
fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd
liftIO $ flip finally (closeFd fd) $ downloadInternal https
host
path
port
stepper
-- TODO: verify md5 during download
let p' = toFilePath p
let p' = toFilePath destFile
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
c <- liftIO $ readFile p
c <- liftIO $ readFile destFile
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
eDigest = view dlHash dli
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
pure p
pure destFile
-- Manage to find a file we can write the body into.
getDestFile :: MonadThrow m => m (Path Abs)
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
path = view (dlUri % pathL') dli
-- | Download or use cached version, if it exists. If filename
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadResource m
, MonadThrow m
@ -255,43 +281,6 @@ downloadBS 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")
@ -334,4 +323,3 @@ downloadInternal https host path port consumer = do
)
closeConnection c

2
lib/GHCup/Types.hs
View File

@ -57,7 +57,7 @@ data DownloadInfo = DownloadInfo
data Tool = GHC
| GHCSrc
| Cabal
| GHCUp
| GHCup
deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest

10
lib/GHCup/Version.hs Normal file
View File

@ -0,0 +1,10 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Version where
import Data.Versions
import GHCup.Utils.Prelude
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.0|]