Lalalal
This commit is contained in:
parent
62b249db2d
commit
63f9bc6b0a
3
TODO.md
3
TODO.md
@ -5,9 +5,6 @@
|
|||||||
* better logs
|
* better logs
|
||||||
* better debug-output
|
* better debug-output
|
||||||
|
|
||||||
* upgrade Upgrade this script in-place
|
|
||||||
* reference tarballs in json
|
|
||||||
|
|
||||||
|
|
||||||
## Maybe
|
## Maybe
|
||||||
|
|
||||||
|
@ -13,6 +13,86 @@ import URI.ByteString.QQ
|
|||||||
import qualified Data.Map as M
|
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 :: BinaryDownloads
|
||||||
binaryDownloads = M.fromList
|
binaryDownloads = M.fromList
|
||||||
[ ( GHC
|
[ ( GHC
|
||||||
@ -21,84 +101,28 @@ binaryDownloads = M.fromList
|
|||||||
, VersionInfo [Latest] $ M.fromList
|
, VersionInfo [Latest] $ M.fromList
|
||||||
[ ( A_64
|
[ ( A_64
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Linux UnknownLinux
|
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)])
|
||||||
, M.fromList
|
, (Linux Ubuntu , M.fromList [(Nothing, ghc_865_64_debian9)])
|
||||||
[ ( 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 Debian
|
, ( Linux Debian
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Nothing
|
[ (Nothing , ghc_865_64_debian9)
|
||||||
, DownloadInfo
|
, (Just $ [vers|8|], ghc_865_64_debian8)
|
||||||
[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|]
|
|
||||||
)
|
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
),
|
)
|
||||||
( [vver|8.4.4|]
|
, ( [vver|8.4.4|]
|
||||||
, VersionInfo [] $ M.fromList
|
, VersionInfo [] $ M.fromList
|
||||||
[ ( A_64
|
[ ( A_64
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Linux UnknownLinux
|
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)])
|
||||||
, M.fromList
|
, (Linux Ubuntu , M.fromList [(Nothing, ghc_844_64_fedora)])
|
||||||
[ ( 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 Debian
|
, ( Linux Debian
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Nothing
|
[ (Nothing , ghc_844_64_debian9)
|
||||||
, DownloadInfo
|
, (Just $ [vers|8|], ghc_844_64_debian8)
|
||||||
[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|]
|
|
||||||
)
|
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
@ -114,16 +138,21 @@ binaryDownloads = M.fromList
|
|||||||
[ ( A_64
|
[ ( A_64
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Linux UnknownLinux
|
[ ( Linux UnknownLinux
|
||||||
|
, M.fromList [(Nothing, cabal_3000_64_linux)]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
, ( GHCup
|
||||||
, M.fromList
|
, M.fromList
|
||||||
[ ( Nothing
|
[ ( [vver|0.1.0|]
|
||||||
, DownloadInfo
|
, VersionInfo [Latest] $ M.fromList
|
||||||
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
|
[ ( A_64
|
||||||
Nothing
|
, M.fromList
|
||||||
[s|32352d2259909970e6ff04faf61bbfac|]
|
[(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]
|
||||||
)
|
|
||||||
]
|
|
||||||
)
|
|
||||||
]
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
|
@ -33,6 +33,7 @@ instance Exception ValidationError
|
|||||||
|
|
||||||
|
|
||||||
-- TODO: test that GHC is in semver
|
-- 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)
|
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
|
||||||
=> GHCupDownloads
|
=> GHCupDownloads
|
||||||
-> m ExitCode
|
-> m ExitCode
|
||||||
|
@ -31,6 +31,7 @@ import Haskus.Utils.Variant.Excepts
|
|||||||
import HPath
|
import HPath
|
||||||
import Options.Applicative hiding ( style )
|
import Options.Applicative hiding ( style )
|
||||||
import System.Console.Pretty
|
import System.Console.Pretty
|
||||||
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
import Text.Read
|
import Text.Read
|
||||||
@ -63,6 +64,7 @@ data Command
|
|||||||
| Rm RmOptions
|
| Rm RmOptions
|
||||||
| DInfo
|
| DInfo
|
||||||
| Compile CompileOptions
|
| Compile CompileOptions
|
||||||
|
| Upgrade UpgradeOpts
|
||||||
|
|
||||||
data ToolVersion = ToolVersion Version
|
data ToolVersion = ToolVersion Version
|
||||||
| ToolTag Tag
|
| ToolTag Tag
|
||||||
@ -96,6 +98,11 @@ data CompileOptions = CompileOptions
|
|||||||
, buildConfig :: Maybe (Path Abs)
|
, buildConfig :: Maybe (Path Abs)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
data UpgradeOpts = UpgradeInplace
|
||||||
|
| UpgradeAt (Path Abs)
|
||||||
|
| UpgradeGHCupDir
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
|
||||||
opts :: Parser Options
|
opts :: Parser Options
|
||||||
opts =
|
opts =
|
||||||
@ -127,7 +134,9 @@ com =
|
|||||||
( command
|
( command
|
||||||
"install"
|
"install"
|
||||||
( Install
|
( Install
|
||||||
<$> (info (installP <**> helper) (progDesc "Install GHC or cabal"))
|
<$> (info (installP <**> helper)
|
||||||
|
(progDesc "Install or update GHC/cabal")
|
||||||
|
)
|
||||||
)
|
)
|
||||||
<> command
|
<> command
|
||||||
"list"
|
"list"
|
||||||
@ -136,6 +145,11 @@ com =
|
|||||||
(progDesc "Show available GHCs and other tools")
|
(progDesc "Show available GHCs and other tools")
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
<> command
|
||||||
|
"upgrade"
|
||||||
|
( Upgrade
|
||||||
|
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)"))
|
||||||
|
)
|
||||||
<> commandGroup "Main commands:"
|
<> commandGroup "Main commands:"
|
||||||
)
|
)
|
||||||
<|> subparser
|
<|> subparser
|
||||||
@ -309,6 +323,32 @@ toSettings Options {..} =
|
|||||||
in Settings { .. }
|
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
|
-- TODO: something better than Show instance for errors
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
@ -387,6 +427,22 @@ main = do
|
|||||||
, JSONError
|
, JSONError
|
||||||
]
|
]
|
||||||
|
|
||||||
|
let runUpgrade =
|
||||||
|
runLogger
|
||||||
|
. flip runReaderT settings
|
||||||
|
. runResourceT
|
||||||
|
. runE
|
||||||
|
@'[ DigestError
|
||||||
|
, URLException
|
||||||
|
, DistroNotFound
|
||||||
|
, PlatformResultError
|
||||||
|
, NoCompatibleArch
|
||||||
|
, NoDownload
|
||||||
|
, FileDoesNotExistError
|
||||||
|
, JSONError
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
case optCommand of
|
case optCommand of
|
||||||
Install (InstallGHC InstallOptions {..}) ->
|
Install (InstallGHC InstallOptions {..}) ->
|
||||||
void
|
void
|
||||||
@ -479,6 +535,30 @@ main = do
|
|||||||
VLeft e ->
|
VLeft e ->
|
||||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
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 ()
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
|
@ -153,6 +153,7 @@ library
|
|||||||
GHCup.Utils.File
|
GHCup.Utils.File
|
||||||
GHCup.Utils.Logger
|
GHCup.Utils.Logger
|
||||||
GHCup.Utils.Prelude
|
GHCup.Utils.Prelude
|
||||||
|
GHCup.Version
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
hs-source-dirs: lib
|
hs-source-dirs: lib
|
||||||
|
49
lib/GHCup.hs
49
lib/GHCup.hs
@ -21,6 +21,7 @@ import GHCup.Types.Optics
|
|||||||
import GHCup.Utils
|
import GHCup.Utils
|
||||||
import GHCup.Utils.File
|
import GHCup.Utils.File
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
|
import GHCup.Version
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
@ -101,8 +102,13 @@ installTool :: ( MonadThrow m
|
|||||||
()
|
()
|
||||||
installTool bDls treq mpfReq = do
|
installTool bDls treq mpfReq = do
|
||||||
lift $ $(logDebug) [i|Requested to install: #{treq}|]
|
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
|
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 ]--
|
--[ Other ]--
|
||||||
|
@ -52,7 +52,6 @@ import "unix-bytestring" System.Posix.IO.ByteString
|
|||||||
( fdWrite )
|
( fdWrite )
|
||||||
import System.Posix.RawFilePath.Directory.Errors
|
import System.Posix.RawFilePath.Directory.Errors
|
||||||
( hideError )
|
( hideError )
|
||||||
import System.Posix.Types
|
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
import URI.ByteString.QQ
|
import URI.ByteString.QQ
|
||||||
|
|
||||||
@ -107,12 +106,9 @@ getDownloadInfo :: ( MonadLogger m
|
|||||||
-> Maybe PlatformRequest
|
-> Maybe PlatformRequest
|
||||||
-> Excepts
|
-> Excepts
|
||||||
'[ DistroNotFound
|
'[ DistroNotFound
|
||||||
, FileDoesNotExistError
|
, PlatformResultError
|
||||||
, JSONError
|
|
||||||
, NoCompatibleArch
|
, NoCompatibleArch
|
||||||
, NoDownload
|
, NoDownload
|
||||||
, PlatformResultError
|
|
||||||
, URLException
|
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
DownloadInfo
|
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
|
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
|
-- | Tries to download from the given http or https url
|
||||||
-- throw an exception if the url type or host protocol is not supported.
|
-- 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.
|
-- The file must not exist.
|
||||||
download :: (MonadLogger m, MonadIO m)
|
download :: (MonadThrow m, MonadLogger m, MonadIO m)
|
||||||
=> DownloadInfo
|
=> DownloadInfo
|
||||||
-> Path Abs -- ^ destination dir
|
-> Path Abs -- ^ destination dir
|
||||||
-> Maybe (Path Rel) -- ^ optional filename
|
-> Maybe (Path Rel) -- ^ optional filename
|
||||||
-> Excepts '[DigestError , URLException] m (Path Abs)
|
-> Excepts '[DigestError , URLException] m (Path Abs)
|
||||||
download dli dest mfn
|
download dli dest mfn | scheme == [s|https|] = dl True
|
||||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
|
| scheme == [s|http|] = dl False
|
||||||
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
|
| scheme == [s|file|] = cp
|
||||||
| otherwise = throwE UnsupportedURL
|
| otherwise = throwE UnsupportedURL
|
||||||
|
|
||||||
where
|
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
|
dl https = do
|
||||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||||
|
|
||||||
host <-
|
host <-
|
||||||
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
||||||
?? UnsupportedURL
|
?? UnsupportedURL
|
||||||
let path = view (dlUri % pathL') dli
|
|
||||||
let port = preview
|
let port = preview
|
||||||
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
||||||
dli
|
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
|
-- TODO: verify md5 during download
|
||||||
let p' = toFilePath p
|
let p' = toFilePath destFile
|
||||||
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
||||||
c <- liftIO $ readFile p
|
c <- liftIO $ readFile destFile
|
||||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
|
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
|
||||||
eDigest = view dlHash dli
|
eDigest = view dlHash dli
|
||||||
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
|
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.
|
-- is omitted, infers the filename from the url.
|
||||||
downloadCached :: ( MonadResource m
|
downloadCached :: ( MonadResource m
|
||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
@ -255,43 +281,6 @@ downloadBS uri'
|
|||||||
liftIO $ downloadBS' https host path port
|
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.
|
-- | Load the result of this download into memory at once.
|
||||||
downloadBS' :: Bool -- ^ https?
|
downloadBS' :: Bool -- ^ https?
|
||||||
-> ByteString -- ^ host (e.g. "www.example.com")
|
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||||
@ -334,4 +323,3 @@ downloadInternal https host path port consumer = do
|
|||||||
)
|
)
|
||||||
|
|
||||||
closeConnection c
|
closeConnection c
|
||||||
|
|
||||||
|
@ -57,7 +57,7 @@ data DownloadInfo = DownloadInfo
|
|||||||
data Tool = GHC
|
data Tool = GHC
|
||||||
| GHCSrc
|
| GHCSrc
|
||||||
| Cabal
|
| Cabal
|
||||||
| GHCUp
|
| GHCup
|
||||||
deriving (Eq, GHC.Generic, Ord, Show)
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
data ToolRequest = ToolRequest
|
data ToolRequest = ToolRequest
|
||||||
|
10
lib/GHCup/Version.hs
Normal file
10
lib/GHCup/Version.hs
Normal 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|]
|
Loading…
Reference in New Issue
Block a user