Lala

TODO.md

@@ -2,15 +2,16 @@
 
 ## New
 
-* download progress
+* better logs
+* better debug-output
 
+* 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
 

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 )
@@ -40,15 +41,17 @@ import qualified Data.Text                     as T
 
 
 data Options = Options
-  { optVerbose   :: Bool
+  {
+  -- global options
+    optVerbose   :: Bool
   , optCache     :: Bool
   , optUrlSource :: Maybe URI
+  -- commands
   , optCommand   :: Command
   }
 
 data Command
-  = InstallGHC InstallGHCOptions
-  | InstallCabal InstallCabalOptions
+  = Install InstallCommand
   | SetGHC SetGHCOptions
   | List ListOptions
   | Rm RmOptions
@@ -58,12 +61,11 @@ data ToolVersion = ToolVersion Version
                  | ToolTag Tag
 
 
-data InstallGHCOptions = InstallGHCOptions
-  { ghcVer :: Maybe ToolVersion
-  }
+data InstallCommand = InstallGHC InstallOptions
+                    | InstallCabal InstallOptions
 
-data InstallCabalOptions = InstallCabalOptions
-  { cabalVer :: Maybe ToolVersion
+data InstallOptions = InstallOptions
+  { instVer :: Maybe ToolVersion
   }
 
 data SetGHCOptions = SetGHCOptions
@@ -105,53 +107,68 @@ opts =
     bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
 
 com :: Parser Command
-com = subparser
-  (  command
-      "install-ghc"
-      (   InstallGHC
-      <$> (info (installGHCOpts <**> helper)
-                (progDesc "Install a GHC version")
+com =
+  subparser
+      (  command
+          "install"
+          (   Install
+          <$> (info (installP <**> helper) (progDesc "Install GHC or cabal"))
           )
+      <> command
+           "list"
+           (   List
+           <$> (info (listOpts <**> helper)
+                     (progDesc "Show available GHCs and other tools")
+               )
+           )
+      <> commandGroup "Main commands:"
+      )
+    <|> subparser
+          (  command
+              "set"
+              (   SetGHC
+              <$> (info (setGHCOpts <**> helper)
+                        (progDesc "Set the currently active GHC version")
+                  )
+              )
+          <> command
+               "rm"
+               (   Rm
+               <$> (info
+                     (rmOpts <**> helper)
+                     (progDesc "Remove a GHC version installed by ghcup")
+                   )
+               )
+          <> commandGroup "GHC commands:"
+          <> hidden
+          )
+    <|> subparser
+          (  command
+              "debug-info"
+              ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
+          <> commandGroup "Other commands:"
+          <> hidden
+          )
+
+
+installP :: Parser InstallCommand
+installP = subparser
+  (  command
+      "ghc"
+      (   InstallGHC
+      <$> (info (installOpts <**> helper) (progDesc "Install a GHC version"))
       )
   <> command
-       "install-cabal"
+       "cabal"
        (   InstallCabal
-       <$> (info (installCabalOpts <**> helper)
-                 (progDesc "Install a cabal-install version")
+       <$> (info (installOpts <**> helper)
+                 (progDesc "Install or update a Cabal version")
            )
        )
-  <> command
-       "set-ghc"
-       (   SetGHC
-       <$> (info (setGHCOpts <**> helper)
-                 (progDesc "Set the currently active GHC version")
-           )
-       )
-  <> command
-       "list"
-       (   List
-       <$> (info (listOpts <**> helper)
-                 (progDesc "Show available GHCs and other tools")
-           )
-       )
-  <> command
-       "rm"
-       (   Rm
-       <$> (info (rmOpts <**> helper)
-                 (progDesc "Remove a GHC version installed by ghcup")
-           )
-       )
-  <> command
-       "debug-info"
-       ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
   )
 
-installGHCOpts :: Parser InstallGHCOptions
-installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
-
-
-installCabalOpts :: Parser InstallCabalOptions
-installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
+installOpts :: Parser InstallOptions
+installOpts = InstallOptions <$> optional toolVersionParser
 
 setGHCOpts :: Parser SetGHCOptions
 setGHCOpts = SetGHCOptions <$> optional toolVersionParser
@@ -194,7 +211,8 @@ rmOpts =
 versionParser :: Parser Version
 versionParser = option
   (eitherReader (bimap (const "Not a valid version") id . version . T.pack))
-  (short 'v' <> long "version" <> metavar "VERSION")
+  (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
+  )
 
 
 toolVersionParser :: Parser ToolVersion
@@ -211,7 +229,7 @@ toolVersionParser = verP <|> toolP
                 other         -> Left ([i|Unknown tag #{other}|])
               )
             )
-            (short 't' <> long "tag" <> metavar "TAG")
+            (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
           )
 
 
@@ -252,6 +270,7 @@ main = do
           let runInstTool =
                 runLogger
                   . flip runReaderT settings
+                  . runResourceT
                   . runE
                     @'[ AlreadyInstalled
                       , ArchiveError
@@ -295,11 +314,11 @@ main = do
                     @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
 
           case optCommand of
-            InstallGHC (InstallGHCOptions {..}) ->
+            Install (InstallGHC InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
                       av <- liftE getDownloads
-                      v  <- liftE $ fromVersion av ghcVer GHC
+                      v  <- liftE $ fromVersion av instVer GHC
                       liftE $ installTool (ToolRequest GHC v) Nothing
                     )
                 >>= \case
@@ -310,11 +329,11 @@ main = do
                           (T.pack (show treq) <> [s| already installed|])
                       VLeft e ->
                         runLogger ($(logError) [i|#{e}|]) >> exitFailure
-            InstallCabal (InstallCabalOptions {..}) ->
+            Install (InstallGHC InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
                       av <- liftE getDownloads
-                      v  <- liftE $ fromVersion av cabalVer Cabal
+                      v  <- liftE $ fromVersion av instVer Cabal
                       liftE $ installTool (ToolRequest Cabal v) Nothing
                     )
                 >>= \case

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

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

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,18 @@ 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|]