Lalalal

TODO.md

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

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
+              [ (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
                 , 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
           [ ( A_64
             , 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
                 , 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,14 +138,7 @@ binaryDownloads = M.fromList
           [ ( A_64
             , M.fromList
               [ ( Linux UnknownLinux
-                , M.fromList
+                , M.fromList [(Nothing, cabal_3000_64_linux)]
-                  [ ( 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|]
-                    )
-                  ]
                 )
               ]
             )
@@ -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)])]
+            )
+          ]
+        )
+      ]
+    )
   ]

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

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 ()
 
 

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

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 ]--

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
+                      , PlatformResultError
-                      , JSONError
                       , 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
+-- | 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
          -> Path Abs          -- ^ destination dir
          -> Maybe (Path Rel)  -- ^ optional filename
          -> 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
+  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
-

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

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|]