From 63f9bc6b0aec7089d1caf86f2eb0453ad953cdfe Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 3 Mar 2020 23:34:25 +0100 Subject: [PATCH] Lalalal --- TODO.md | 3 - app/ghcup-gen/BinaryDownloads.hs | 177 ++++++++++++++++++------------- app/ghcup-gen/Validate.hs | 1 + app/ghcup/Main.hs | 88 ++++++++++++++- ghcup.cabal | 1 + lib/GHCup.hs | 49 ++++++++- lib/GHCup/Download.hs | 102 ++++++++---------- lib/GHCup/Types.hs | 2 +- lib/GHCup/Version.hs | 10 ++ 9 files changed, 292 insertions(+), 141 deletions(-) create mode 100644 lib/GHCup/Version.hs diff --git a/TODO.md b/TODO.md index a8a144b..3ddefec 100644 --- a/TODO.md +++ b/TODO.md @@ -5,9 +5,6 @@ * better logs * better debug-output -* upgrade Upgrade this script in-place -* reference tarballs in json - ## Maybe diff --git a/app/ghcup-gen/BinaryDownloads.hs b/app/ghcup-gen/BinaryDownloads.hs index 3aa3fc3..e726df5 100644 --- a/app/ghcup-gen/BinaryDownloads.hs +++ b/app/ghcup-gen/BinaryDownloads.hs @@ -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,14 +138,7 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ ( Linux UnknownLinux - , M.fromList - [ ( Nothing - , DownloadInfo - [uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|] - Nothing - [s|32352d2259909970e6ff04faf61bbfac|] - ) - ] + , M.fromList [(Nothing, cabal_3000_64_linux)] ) ] ) @@ -129,4 +146,16 @@ binaryDownloads = M.fromList ) ] ) + , ( GHCup + , M.fromList + [ ( [vver|0.1.0|] + , VersionInfo [Latest] $ M.fromList + [ ( A_64 + , M.fromList + [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])] + ) + ] + ) + ] + ) ] diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 8d556b4..e50c8f9 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index eaa7e87..6779195 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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,12 +427,28 @@ 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 $ (runInstTool $ do dls <- _binaryDownloads <$> liftE getDownloads - v <- liftE $ fromVersion dls instVer GHC + v <- liftE $ fromVersion dls instVer GHC liftE $ installTool dls (ToolRequest GHC v) Nothing ) >>= \case @@ -407,7 +463,7 @@ main = do void $ (runInstTool $ do dls <- _binaryDownloads <$> liftE getDownloads - v <- liftE $ fromVersion dls instVer Cabal + v <- liftE $ fromVersion dls instVer Cabal liftE $ installTool dls (ToolRequest Cabal v) Nothing ) >>= \case @@ -423,7 +479,7 @@ main = do void $ (runSetGHC $ do dls <- _binaryDownloads <$> liftE getDownloads - v <- liftE $ fromVersion dls ghcVer GHC + v <- liftE $ fromVersion dls ghcVer GHC liftE $ setGHC v SetGHCOnly ) >>= \case @@ -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 () diff --git a/ghcup.cabal b/ghcup.cabal index aacc57f..8fe8512 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -153,6 +153,7 @@ library GHCup.Utils.File GHCup.Utils.Logger GHCup.Utils.Prelude + GHCup.Version -- other-modules: -- other-extensions: hs-source-dirs: lib diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 083e5e1..4dd48c4 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 ]-- diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 2575091..40e192e 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 - | otherwise = throwE UnsupportedURL +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 - diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 596d934..86628e5 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -57,7 +57,7 @@ data DownloadInfo = DownloadInfo data Tool = GHC | GHCSrc | Cabal - | GHCUp + | GHCup deriving (Eq, GHC.Generic, Ord, Show) data ToolRequest = ToolRequest diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs new file mode 100644 index 0000000..f28925b --- /dev/null +++ b/lib/GHCup/Version.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE QuasiQuotes #-} + + +module GHCup.Version where + +import Data.Versions +import GHCup.Utils.Prelude + +ghcUpVer :: PVP +ghcUpVer = [pver|0.1.0|]