Improve error handling

app/ghcup-gen/Validate.hs

@@ -161,7 +161,7 @@ validateTarballs dls = do
 
  where
   downloadAll dli = do
-    let settings = Settings True GHCupURL False
+    let settings = Settings True False
     let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
                                            , colorOutter  = B.hPut stderr
                                            , rawOutter    = (\_ -> pure ())

app/ghcup/Main.hs

@@ -416,6 +416,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
   distroP :: MP.Parsec Void Text LinuxDistro
   distroP = choice'
     [ MP.chunk [s|debian|] $> Debian
+    , MP.chunk [s|deb|] $> Debian
     , MP.chunk [s|ubuntu|] $> Ubuntu
     , MP.chunk [s|mint|] $> Mint
     , MP.chunk [s|fedora|] $> Fedora
@@ -454,9 +455,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
 
 toSettings :: Options -> Settings
 toSettings Options {..} =
-  let cache     = optCache
-      urlSource = maybe GHCupURL OwnSource optUrlSource
-      noVerify  = optNoVerify
+  let cache    = optCache
+      noVerify = optNoVerify
   in  Settings { .. }
 
 
@@ -588,11 +588,16 @@ main = do
                       , DownloadFailed
                       ]
 
+          -- create ~/.ghcup dir
+          ghcdir <- ghcupBaseDir
+          createDirIfMissing newDirPerms ghcdir
+
           dls <-
             ( runLogger
               . flip runReaderT settings
               . runE @'[JSONError , DownloadFailed]
-              $ liftE getDownloads
+              $ liftE
+              $ getDownloads (maybe GHCupURL OwnSource optUrlSource)
               )
               >>= \case
                     VRight r -> pure r
@@ -607,7 +612,7 @@ main = do
               void
                 $   (runInstTool $ do
                       v <- liftE $ fromVersion dls instVer GHC
-                      liftE $ installGHCBin dls v Nothing
+                      liftE $ installGHCBin dls v optPlatform
                     )
                 >>= \case
                       VRight _ -> runLogger
@@ -618,7 +623,7 @@ main = do
                       VLeft (V (BuildFailed tmpdir e)) ->
                         runLogger
                             ($(logError) [i|Build failed with #{e}
-Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
                             )
                           >> exitFailure
                       VLeft e -> do
@@ -630,7 +635,7 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
               void
                 $   (runInstTool $ do
                       v <- liftE $ fromVersion dls instVer Cabal
-                      liftE $ installCabalBin dls v Nothing
+                      liftE $ installCabalBin dls v optPlatform
                     )
                 >>= \case
                       VRight _ -> runLogger
@@ -702,7 +707,7 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
                       VLeft (V (BuildFailed tmpdir e)) ->
                         runLogger
                             ($(logError) [i|Build failed with #{e}
-Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
                             )
                           >> exitFailure
                       VLeft e ->
@@ -720,7 +725,7 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
                       VLeft (V (BuildFailed tmpdir e)) ->
                         runLogger
                             ($(logError) [i|Build failed with #{e}
-Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
                             )
                           >> exitFailure
                       VLeft e ->

lib/GHCup.hs

@@ -108,14 +108,18 @@ installGHCBin bDls ver mpfReq = do
   ghcdir <- liftIO $ ghcupGHCDir ver
 
   -- the subdir of the archive where we do the work
-  let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
+  let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
 
-  catchAllE
-      (\es ->
-        liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
-          >> throwE (BuildFailed archiveSubdir es)
-      )
-    $ installGHC' archiveSubdir ghcdir
+  -- Be careful about cleanup. We must catch both pure exceptions
+  -- as well as async ones.
+  flip onException
+       (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+    $ catchAllE
+        (\es -> do
+          liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+            >> throwE (BuildFailed workdir es)
+        )
+    $ installGHC' workdir ghcdir
 
   -- only clean up dir if the build succeeded
   liftIO $ deleteDirRecursive tmpUnpack
@@ -183,9 +187,9 @@ installCabalBin bDls ver mpfReq = do
   bindir <- liftIO ghcupBinDir
 
   -- the subdir of the archive where we do the work
-  let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
+  let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
 
-  liftE $ installCabal' archiveSubdir bindir
+  liftE $ installCabal' workdir bindir
   pure ()
 
  where
@@ -335,7 +339,7 @@ listVersions av lt criteria = case lt of
       fromSrc    <- ghcSrcInstalled v
       pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
     Cabal -> do
-      lSet       <- fmap (== v) $ cabalSet
+      lSet <- fmap (== v) $ cabalSet
       let lInstalled = lSet
       pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
     GHCup -> do
@@ -404,19 +408,18 @@ rmGHCVer ver = do
     ------------------
 
 
-getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
+getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
              => Excepts
                   '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
                   m
                   DebugInfo
 getDebugInfo = do
-  diBaseDir   <- liftIO $ ghcupBaseDir
-  diBinDir    <- liftIO $ ghcupBinDir
-  diGHCDir    <- liftIO $ ghcupGHCBaseDir
-  diCacheDir  <- liftIO $ ghcupCacheDir
-  diURLSource <- lift $ getUrlSource
-  diArch      <- lE getArchitecture
-  diPlatform  <- liftE $ getPlatform
+  diBaseDir  <- liftIO $ ghcupBaseDir
+  diBinDir   <- liftIO $ ghcupBinDir
+  diGHCDir   <- liftIO $ ghcupGHCBaseDir
+  diCacheDir <- liftIO $ ghcupCacheDir
+  diArch     <- lE getArchitecture
+  diPlatform <- liftE $ getPlatform
   pure $ DebugInfo { .. }
 
 
@@ -468,11 +471,15 @@ compileGHC dls tver bver jobs mbuildConfig = do
   let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
   ghcdir <- liftIO $ ghcupGHCDir tver
 
-  catchAllE
-      (\es ->
-        liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
-          >> throwE (BuildFailed workdir es)
-      )
+  -- Be careful about cleanup. We must catch both pure exceptions
+  -- as well as async ones.
+  flip onException
+       (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+    $ catchAllE
+        (\es ->
+          liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+            >> throwE (BuildFailed workdir es)
+        )
     $ compile bghc ghcdir workdir
   markSrcBuilt ghcdir workdir
 

lib/GHCup/Download.hs

@@ -43,7 +43,7 @@ import           Data.Time.Format
 import           Data.Versions
 import           GHC.IO.Exception
 import           HPath
-import           HPath.IO
+import           HPath.IO                      as HIO
 import           Haskus.Utils.Variant.Excepts
 import           Network.Http.Client     hiding ( URL )
 import           OpenSSL.Digest
@@ -93,14 +93,13 @@ getDownloads :: ( FromJSONKey Tool
                 , FromJSON VersionInfo
                 , MonadIO m
                 , MonadCatch m
-                , MonadReader Settings m
                 , MonadLogger m
                 , MonadThrow m
                 , MonadFail m
                 )
-             => Excepts '[JSONError , DownloadFailed] m GHCupDownloads
-getDownloads = do
-  urlSource <- lift getUrlSource
+             => URLSource
+             -> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
+getDownloads urlSource = do
   lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
   case urlSource of
     GHCupURL -> do
@@ -122,23 +121,27 @@ getDownloads = do
   --
   -- Always save the local file with the mod time of the remote file.
   smartDl :: forall m1
-      . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
-     => URI
-     -> Excepts
-          '[ FileDoesNotExistError
-           , HTTPStatusError
-           , URIParseError
-           , UnsupportedScheme
-           , NoLocationHeader
-           , TooManyRedirs
-           ]
-          m1
-          L.ByteString
+           . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
+          => URI
+          -> Excepts
+               '[ FileDoesNotExistError
+                , HTTPStatusError
+                , URIParseError
+                , UnsupportedScheme
+                , NoLocationHeader
+                , TooManyRedirs
+                ]
+               m1
+               L.ByteString
   smartDl uri' = do
     let path = view pathL' uri'
     json_file <- (liftIO $ ghcupCacheDir)
       >>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
-    e <- liftIO $ doesFileExist json_file
+    e <-
+      liftIO
+      $ HIO.handleIOError
+          (\e -> if isDoesNotExistError e then pure False else throwIO e)
+      $ doesFileExist json_file
     if e
       then do
         accessTime <-
@@ -204,11 +207,7 @@ getDownloads = do
 
 
 
-getDownloadInfo :: ( MonadLogger m
-                   , MonadCatch m
-                   , MonadIO m
-                   , MonadReader Settings m
-                   )
+getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
                 => GHCupDownloads
                 -> Tool
                 -> Version

lib/GHCup/Types.hs

@@ -104,21 +104,19 @@ data URLSource = GHCupURL
 
 
 data Settings = Settings
-  { cache     :: Bool
-  , urlSource :: URLSource
-  , noVerify  :: Bool
+  { cache    :: Bool
+  , noVerify :: Bool
   }
   deriving Show
 
 
 data DebugInfo = DebugInfo
-  { diBaseDir   :: Path Abs
-  , diBinDir    :: Path Abs
-  , diGHCDir    :: Path Abs
-  , diCacheDir  :: Path Abs
-  , diURLSource :: URLSource
-  , diArch      :: Architecture
-  , diPlatform  :: PlatformResult
+  { diBaseDir  :: Path Abs
+  , diBinDir   :: Path Abs
+  , diGHCDir   :: Path Abs
+  , diCacheDir :: Path Abs
+  , diArch     :: Architecture
+  , diPlatform :: PlatformResult
   }
   deriving Show
 
@@ -141,4 +139,3 @@ data PlatformRequest = PlatformRequest
   , _rVersion  :: Maybe Versioning
   }
   deriving (Eq, Show)
-

lib/GHCup/Utils.hs

@@ -277,9 +277,6 @@ getRecommended av tool = headOf folded $ getTagged av tool Recommended
     -----------------------
 
 
-getUrlSource :: MonadReader Settings m => m URLSource
-getUrlSource = ask <&> urlSource
-
 getCache :: MonadReader Settings m => m Bool
 getCache = ask <&> cache