diff --git a/TODO.md b/TODO.md index e8ea0c5..a27f467 100644 --- a/TODO.md +++ b/TODO.md @@ -2,15 +2,15 @@ ## New -* download progress +* proper subcommands: ghcup install ghc +* download progress * upgrade Upgrade this script in-place * maybe: changelog Show the changelog of a GHC release (online) * maybe: print-system-reqs Print an approximation of system requirements * testing (especially distro detection -> unit tests) -* TODO: cleanup temp files after use ## Old diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e4560ca..39517cb 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -16,6 +16,7 @@ import GHCup.Types import Control.Monad.Logger import Control.Monad.Reader +import Control.Monad.Trans.Resource import Data.Bifunctor import Data.Char import Data.List ( intercalate ) @@ -252,6 +253,7 @@ main = do let runInstTool = runLogger . flip runReaderT settings + . runResourceT . runE @'[ AlreadyInstalled , ArchiveError diff --git a/ghcup.cabal b/ghcup.cabal index 93d83c4..a10ecc8 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -23,16 +23,16 @@ source-repository head common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 } common aeson { build-depends: aeson >= 1.4 } common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 } -common attoparsec { build-depends: attoparsec >= 0.13 } common ascii-string { build-depends: ascii-string >= 1.0 } common async { build-depends: async >= 0.8 } +common attoparsec { build-depends: attoparsec >= 0.13 } common base { build-depends: base >= 4.12 && < 5 } common bytestring { build-depends: bytestring >= 0.10 } common bzlib { build-depends: bzlib >= 0.5.0.5 } common containers { build-depends: containers >= 0.6 } common generics-sop { build-depends: generics-sop >= 0.5 } -common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 } +common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } common hpath { build-depends: hpath >= 0.11 } common hpath-directory { build-depends: hpath-directory >= 0.13.2 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } @@ -49,13 +49,14 @@ common optics-vl { build-depends: optics-vl >= 0.2 } common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 } common parsec { build-depends: parsec >= 3.1 } common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 } +common resourcet { build-depends: resourcet >= 1.2.2 } common safe { build-depends: safe >= 0.3.18 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common streamly { build-depends: streamly >= 0.7 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common strict-base { build-depends: strict-base >= 0.4 } -common string-qq { build-depends: string-qq >= 0.0.4 } common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 } +common string-qq { build-depends: string-qq >= 0.0.4 } common table-layout { build-depends: table-layout >= 0.8 } common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 } common template-haskell { build-depends: template-haskell >= 2.7 } @@ -98,8 +99,8 @@ library , bzlib , containers , generics-sop - , haskus-utils-variant , haskus-utils-types + , haskus-utils-variant , hpath , hpath-directory , hpath-filepath @@ -115,13 +116,14 @@ library , optics-vl , parsec , pretty-terminal + , resourcet , safe , safe-exceptions , streamly , streamly-bytestring , strict-base - , string-qq , string-interpolate + , string-qq , tar-bytestring , template-haskell , text @@ -161,6 +163,7 @@ executable ghcup , versions , hpath , pretty-terminal + , resourcet , string-qq , string-interpolate , table-layout diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e429848..e93b272 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -26,6 +26,8 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.Resource + hiding ( throwM ) import Data.Aeson import Data.Attoparsec.ByteString import Data.ByteString ( ByteString ) @@ -51,9 +53,7 @@ import Prelude hiding ( abs import Safe import System.IO.Error import System.Info -import System.Posix.Env.ByteString ( getEnvDefault - , getEnv - ) +import System.Posix.Env.ByteString ( getEnv ) import System.Posix.FilePath ( takeFileName ) import System.Posix.Files.ByteString ( readSymbolicLink ) import "unix" System.Posix.IO.ByteString @@ -62,7 +62,6 @@ import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) import System.Posix.RawFilePath.Directory.Errors ( hideError ) -import System.Posix.Temp.ByteString import System.Posix.Types import URI.ByteString import URI.ByteString.QQ @@ -553,7 +552,8 @@ installTool :: ( MonadThrow m , MonadCatch m , MonadIO m , MonadFail m - ) + , MonadResource m + ) -- tmp file => ToolRequest -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Excepts @@ -591,7 +591,7 @@ installTool treq mpfReq = do | fileExists -> pure $ cachfile | otherwise -> liftE $ download dlinfo cachedir Nothing False -> do - tmp <- liftIO mkGhcupTmpDir + tmp <- lift withGHCupTmpDir liftE $ download dlinfo tmp Nothing -- unpack @@ -821,7 +821,7 @@ rmGHCVer ver = do lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] liftIO $ rmMinorSymlinks - lift $ $(logInfo) [i|Removing ghc-x.y symlinks|] + lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|] liftE fixMajorSymlinks when isSetGHC $ liftE $ do @@ -1011,15 +1011,15 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False -- | Unpack an archive to a temporary directory and return that path. -unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m) +unpackToTmpDir :: (MonadResource m -- temp file + , MonadLogger m, MonadIO m, MonadThrow m) => Path Abs -- ^ archive path -> Excepts '[ArchiveError] m (Path Abs) unpackToTmpDir av = do let fp = E.decodeUtf8 (toFilePath av) lift $ $(logInfo) [i|Unpacking: #{fp}|] - fn <- toFilePath <$> basename av - tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] - tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) + fn <- toFilePath <$> basename av + tmp <- toFilePath <$> lift withGHCupTmpDir let untar bs = do Tar.unpack tmp . Tar.read $ bs parseAbs tmp diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index ce9f86b..e923867 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -5,6 +5,8 @@ module GHCup.File where import Control.Exception.Safe import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Data.ByteString import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import Data.Char @@ -186,13 +188,19 @@ toProcessError exe args mps = case mps of Nothing -> Left $ NoSuchPid exe args -mkGhcupTmpDir :: IO (Path Abs) +mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs) mkGhcupTmpDir = do - tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|] - tmp <- mkdtemp $ (tmpdir FP. [s|ghcup-|]) + tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] + tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) + liftIO $ System.IO.putStrLn $ show tmp parseAbs tmp +withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) + => m (Path Abs) +withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive + + getHomeDirectory :: IO (Path Abs) getHomeDirectory = do e <- getEnv [s|HOME|]