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

Use strongly types GHCupPath and restrict destructive operations

Browse Source
This commit is contained in:
Julian Ospald
2022-05-13 21:35:34 +02:00
parent fa924eac15
commit c9790e5823
21 changed files with 421 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
app/ghcup/GHCup/OptParse/Common.hs
View File

@@ -52,7 +52,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import Safe
import System.Directory
import System.Process ( readProcess )
import System.FilePath
import Text.HTML.TagSoup hiding ( Tag )

4
app/ghcup/GHCup/OptParse/Compile.hs
View File

@@ -494,7 +494,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
@@ -553,7 +553,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9

13
app/ghcup/GHCup/OptParse/Install.hs
View File

@@ -18,6 +18,7 @@ import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
@@ -446,21 +447,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _, ())) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3
@@ -512,7 +513,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
installHLS :: InstallOptions -> IO ExitCode
@@ -572,7 +573,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
installStack :: InstallOptions -> IO ExitCode
@@ -623,6 +624,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4

1
app/ghcup/GHCup/OptParse/Run.hs
View File

@@ -32,7 +32,6 @@ import Data.List ( intercalate )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Directory
import System.FilePath
import System.Environment
import System.Exit

9
app/ghcup/GHCup/OptParse/Whereis.hs
View File

@@ -17,6 +17,7 @@ import GHCup
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
@@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do
liftIO $ putStr baseDir
liftIO $ putStr $ fromGHCupPath baseDir
pure ExitSuccess
(WhereisBinDir, _) -> do
@@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure ExitSuccess
(WhereisCacheDir, _) -> do
liftIO $ putStr cacheDir
liftIO $ putStr $ fromGHCupPath cacheDir
pure ExitSuccess
(WhereisLogsDir, _) -> do
liftIO $ putStr logsDir
liftIO $ putStr $ fromGHCupPath logsDir
pure ExitSuccess
(WhereisConfDir, _) -> do
liftIO $ putStr confDir
liftIO $ putStr $ fromGHCupPath confDir
pure ExitSuccess