hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve error handling

Browse Source
This commit is contained in:
Julian Ospald 2020-03-17 18:40:25 +01:00
parent 9c7d17800d
commit 35b6359c1b
2 changed files with 29 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
lib/GHCup.hs
View File

@ -108,14 +108,18 @@ installGHCBin bDls ver mpfReq = do
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- liftIO $ ghcupGHCDir ver
-- the subdir of the archive where we do the work -- 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 -- Be careful about cleanup. We must catch both pure exceptions
(\es -> -- as well as async ones.
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) flip onException
>> throwE (BuildFailed archiveSubdir es) (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
) $ catchAllE
$ installGHC' archiveSubdir ghcdir (\es -> do
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
>> throwE (BuildFailed workdir es)
)
$ installGHC' workdir ghcdir
-- only clean up dir if the build succeeded -- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack liftIO $ deleteDirRecursive tmpUnpack
@ -183,9 +187,9 @@ installCabalBin bDls ver mpfReq = do
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work -- 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 () pure ()
where where
@ -335,7 +339,7 @@ listVersions av lt criteria = case lt of
fromSrc <- ghcSrcInstalled v fromSrc <- ghcSrcInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. } pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
Cabal -> do Cabal -> do
lSet <- fmap (== v) $ cabalSet lSet <- fmap (== v) $ cabalSet
let lInstalled = lSet let lInstalled = lSet
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. } pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
GHCup -> do GHCup -> do
@ -467,11 +471,15 @@ compileGHC dls tver bver jobs mbuildConfig = do
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- liftIO $ ghcupGHCDir tver
catchAllE -- Be careful about cleanup. We must catch both pure exceptions
(\es -> -- as well as async ones.
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) flip onException
>> throwE (BuildFailed workdir es) (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
) $ catchAllE
(\es ->
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
>> throwE (BuildFailed workdir es)
)
$ compile bghc ghcdir workdir $ compile bghc ghcdir workdir
markSrcBuilt ghcdir workdir markSrcBuilt ghcdir workdir

8
lib/GHCup/Download.hs
View File

@ -43,7 +43,7 @@ import Data.Time.Format
import Data.Versions import Data.Versions
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
import HPath.IO import HPath.IO as HIO
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL ) import Network.Http.Client hiding ( URL )
import OpenSSL.Digest import OpenSSL.Digest
@ -137,7 +137,11 @@ getDownloads urlSource = do
let path = view pathL' uri' let path = view pathL' uri'
json_file <- (liftIO $ ghcupCacheDir) json_file <- (liftIO $ ghcupCacheDir)
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path >>= \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 if e
then do then do
accessTime <- accessTime <-