Lalalal

2020-03-03 23:34:25 +01:00
parent 62b249db2d
commit 63f9bc6b0a
9 changed files with 292 additions and 141 deletions
--- 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 ]--
--- 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
-
--- 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
--- a/lib/GHCup/Version.hs
+++ 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|]