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

Implement GPG verification wrt #236

Browse Source
This commit is contained in:
Julian Ospald 2021-09-18 19:45:32 +02:00
parent 6f61b5dbef
commit c431c0ae00
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
12 changed files with 290 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
README.md
View File

@ -18,6 +18,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Configuration](#configuration)
* [GPG verification](#gpg-verification)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Compiling GHC from source](#compiling-ghc-from-source)
@ -146,6 +147,34 @@ explaining all possible configurations can be found in this repo: [config.yaml](
Partial configuration is fine. Command line options always override the config file settings.
### GPG verification
GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
this is cryptographically secure.
First, obtain the gpg key:
```sh
gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
```
Then verify the gpg key in one of these ways:
1. find out where I live and visit me to do offline key signing
2. figure out my mobile phone number and call me to verify the fingerprint
3. more boring: contact me on Libera IRC (`maerwald`) and verify the fingerprint
Once you've verified the key, you have to figure out if you trust me.
If you trust me, then you can configure gpg in `~/.ghcup/config.yaml`:
```yml
gpg-setting: GPGLax # GPGStrict | GPGLax | GPGNone
```
In `GPGStrict` mode, ghcup will fail if verification fails. In `GPGLax` mode it will just print a warning.
You can also pass the mode via `ghcup --gpg <strict|lax|none>`.
### Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
@ -206,6 +235,7 @@ This is the complete list of env variables that change GHCup behavior:
* `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
* `GHCUP_CURL_OPTS`: additional options that can be passed to curl
* `GHCUP_WGET_OPTS`: additional options that can be passed to wget
* `GHCUP_GPG_OPTS`: additional options that can be passed to gpg
* `GHCUP_SKIP_UPDATE_CHECK`: Skip the (possibly annoying) update check when you run a command
* `CC`/`LD` etc.: full environment is passed to the build system when compiling GHC via GHCup

4
app/ghcup-gen/Main.hs
View File

@ -119,7 +119,7 @@ main = do
, rawOutter = \_ -> pure ()
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings loggerConfig
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
@ -129,7 +129,7 @@ main = do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of

5
app/ghcup-gen/Validate.hs
View File

@ -229,6 +229,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, GPGError
, DownloadFailed
, UnknownArchive
, ArchiveResult
@ -237,7 +238,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
Right _ -> do
p <- liftE $ downloadCached dli Nothing
@ -247,7 +248,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
case r of
VRight (Just basePath) -> do

4
app/ghcup/BrickMain.hs
View File

@ -429,6 +429,7 @@ install' _ (_, ListResult {..}) = do
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
@ -547,6 +548,7 @@ settings' = unsafePerformIO $ do
, verbose = False
, urlSource = GHCupURL
, noNetwork = False
, gpgSetting = GPGNone
, ..
})
dirs
@ -591,7 +593,7 @@ getGHCupInfo = do
r <-
flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF

31
app/ghcup/Main.hs
View File

@ -94,6 +94,7 @@ data Options = Options
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting
-- commands
, optCommand :: Command
}
@ -310,6 +311,13 @@ opts =
<> hidden
))
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> optional (option
(eitherReader gpgParser)
( long "gpg"
<> metavar "<strict|lax|none>"
<> help
"GPG verification (default: none)"
))
<*> com
where
parseUri s' =
@ -1145,7 +1153,7 @@ tagCompleter tool add = listIOCompleter $ do
, rawOutter = mempty
}
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
(Settings True False Never Curl False GHCupURL True GPGNone)
dirs'
defaultKeyBindings
loggerConfig
@ -1170,7 +1178,7 @@ versionCompleter criteria tool = listIOCompleter $ do
, colorOutter = mempty
, rawOutter = mempty
}
let settings = Settings True False Never Curl False GHCupURL True
let settings = Settings True False Never Curl False GHCupURL True GPGNone
let leanAppState = LeanAppState
settings
dirs'
@ -1257,6 +1265,13 @@ downloaderParser s' | t == T.pack "curl" = Right Curl
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
gpgParser :: String -> Either String GPGSetting
gpgParser s' | t == T.pack "strict" = Right GPGStrict
| t == T.pack "lax" = Right GPGLax
| t == T.pack "none" = Right GPGNone
| otherwise = Left ("Unknown gpg setting value: " <> s')
where t = T.toLower (T.pack s')
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
@ -1336,6 +1351,7 @@ toSettings options = do
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
@ -1371,7 +1387,8 @@ updateSettings config settings = do
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork'
gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting'
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
@ -1396,7 +1413,7 @@ describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL False)
let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone)
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
@ -1506,7 +1523,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
ghcupInfo <-
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
)
@ -1579,6 +1596,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
@ -1669,6 +1687,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
@ -1707,6 +1726,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, GPGError
, NoDownload
, NoUpdate
, FileDoesNotExistError
@ -1723,6 +1743,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
, NoDownload
, DigestError
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError

4
data/config.yaml
View File

@ -8,6 +8,10 @@ verbose: False
keep-dirs: Errors # Always | Never | Errors
# Which downloader to use
downloader: Curl # Curl | Wget | Internal
# whether to run in offline mode
no-network: False
# whether/how to do gpg verification
gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
# TUI key bindings,
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key

15
lib/GHCup.hs
View File

@ -121,6 +121,7 @@ fetchToolBindist :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, GPGError
, DownloadFailed
, NoDownload
]
@ -148,6 +149,7 @@ fetchGHCSrc :: ( MonadFail m
-> Maybe FilePath
-> Excepts
'[ DigestError
, GPGError
, DownloadFailed
, NoDownload
]
@ -189,6 +191,7 @@ installGHCBindist :: ( MonadFail m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -384,6 +387,7 @@ installGHCBin :: ( MonadFail m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -421,6 +425,7 @@ installCabalBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -526,6 +531,7 @@ installCabalBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -563,6 +569,7 @@ installHLSBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -693,6 +700,7 @@ installHLSBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -731,6 +739,7 @@ installStackBin :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -768,6 +777,7 @@ installStackBindist :: ( MonadMask m
'[ AlreadyInstalled
, CopyError
, DigestError
, GPGError
, DownloadFailed
, NoDownload
, NotInstalled
@ -1862,6 +1872,7 @@ compileGHC :: ( MonadMask m
'[ AlreadyInstalled
, BuildFailed
, DigestError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
@ -2309,6 +2320,8 @@ upgradeGHCup :: ( MonadMask m
-> Excepts
'[ CopyError
, DigestError
, GPGError
, GPGError
, DownloadFailed
, NoDownload
, NoUpdate
@ -2325,7 +2338,7 @@ upgradeGHCup mtarget force' = do
dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- lift withGHCupTmpDir
let fn = "ghcup" <> exeExt
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ logDebug $ "mkdir -p " <> T.pack destDir

191
lib/GHCup/Download.hs
View File

@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadMask m
)
=> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF = do
@ -165,7 +165,7 @@ getBase :: ( MonadReader env m
, MonadMask m
)
=> URI
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do
Settings { noNetwork, downloader } <- lift getSettings
@ -176,7 +176,6 @@ getBase uri = do
then pure Nothing
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. fmap Just
. smartDl
$ uri
@ -234,6 +233,7 @@ getBase uri = do
-> Excepts
'[ DownloadFailed
, DigestError
, GPGError
]
m1
FilePath
@ -245,7 +245,7 @@ getBase uri = do
Dirs { cacheDir } <- lift getDirs
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
| e -> do
accessTime <- liftIO $ getAccessTime json_file
@ -258,7 +258,7 @@ getBase uri = do
where
dlWithMod modTime json_file = do
let (dir, fn) = splitFileName json_file
f <- liftE $ download uri' Nothing dir (Just fn) True
f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
liftIO $ setModificationTime f modTime
liftIO $ setAccessTime f modTime
pure f
@ -322,16 +322,17 @@ download :: ( MonadReader env m
, MonadIO m
)
=> URI
-> Maybe URI -- ^ URI for gpg sig
-> Maybe T.Text -- ^ expected hash
-> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError , DownloadFailed] m FilePath
download uri eDigest dest mfn etags
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest dest mfn etags
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
@ -340,35 +341,89 @@ download uri eDigest dest mfn etags
where
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
-- download
flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
(\e' -> do
lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
case e' of
V e@GPGError {} -> throwE e
V e@DigestError {} -> throwE e
_ -> throwE (DownloadFailed e')
) $ do
Settings{ downloader, noNetwork } <- lift getSettings
Settings{ downloader, noNetwork, gpgSetting } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
case downloader of
downloadAction <- case downloader of
Curl -> do
o' <- liftIO getCurlOpts
if etags
then do
then pure $ curlEtagsDL o'
else pure $ curlDL o'
Wget -> do
o' <- liftIO getWgetOpts
if etags
then pure $ wgetEtagsDL o'
else pure $ wgetDL o'
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
if etags
then pure (\fp -> liftE . internalEtagsDL fp)
else pure (\fp -> liftE . internalDL fp)
#endif
liftE $ downloadAction baseDestFile uri
case (gpgUri, gpgSetting) of
(_, GPGNone) -> pure ()
(Just gpgUri', _) -> do
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
liftE $ flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
) $ do
o' <- liftIO getGpgOpts
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
liftE $ downloadAction gpgDestFile gpgUri'
lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
cp <- lift $ executeOut "gpg" args Nothing
case cp of
CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
lift $ logDebug $ decUTF8Safe' _stdErr
throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
_ -> pure ()
forM_ eDigest (liftE . flip checkDigest baseDestFile)
pure baseDestFile
curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
liftIO $ renameFile destFileTemp destFile
curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
headers <- liftIO $ T.readFile dh
-- this nonsense is necessary, because some older versions of curl would overwrite
@ -379,27 +434,33 @@ download uri eDigest dest mfn etags
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
liftIO $ renameFile destFileTemp destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
lift $ writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
Wget -> do
destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ renameFile destFileTemp destFile
wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
o' <- liftIO getWgetOpts
if etags
then do
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
@ -408,47 +469,51 @@ download uri eDigest dest mfn etags
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ copyFile destFileTemp destFile
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFileTemp mempty
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalEtagsDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
r <- downloadToFile https host fullPath port destFileTemp addHeaders
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFile mempty
#endif
forM_ eDigest (liftE . flip checkDigest destFile)
pure destFile
-- Manage to find a file we can write the body into.
getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
getDestFile =
case mfn of
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' =
let path = view pathL' uri'
in case mfn' of
Just fn -> pure (dest </> fn)
Nothing
| let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
, not (null urlBase) -> pure (dest </> urlBase)
-- TODO: remove this once we use hpath again
| otherwise -> throwE $ NoUrlBase uri'
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
| otherwise -> throwE $ NoUrlBase (decUTF8Safe . serializeURIRef' $ uri')
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
@ -509,14 +574,14 @@ downloadCached :: ( MonadReader env m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
case cache of
True -> downloadCached' dli mfn Nothing
False -> do
tmp <- lift withGHCupTmpDir
liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
downloadCached' :: ( MonadReader env m
@ -531,7 +596,7 @@ downloadCached' :: ( MonadReader env m
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[DigestError , DownloadFailed] m FilePath
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe cacheDir mDestDir
@ -542,7 +607,7 @@ downloadCached' dli mfn mDestDir = do
| fileExists -> do
liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile
| otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
@ -589,6 +654,12 @@ getWgetOpts =
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional gpg args from env. This is an undocumented option.
getGpgOpts :: IO [String]
getGpgOpts =
lookupEnv "GHCUP_GPG_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get the url base name.
--
@ -610,3 +681,7 @@ urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-- "HTTP/1.1 304 Not Modified\n"
getLastHeader :: T.Text -> T.Text
getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines
tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp")

8
lib/GHCup/Errors.hs
View File

@ -195,6 +195,14 @@ instance Pretty DigestError where
pPrint (DigestError currentDigest expectedDigest) =
text "Digest error: expected" <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest
-- | File digest verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
deriving Show

13
lib/GHCup/Types.hs
View File

@ -303,11 +303,12 @@ data UserSettings = UserSettings
, uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
@ -320,6 +321,7 @@ fromSettings Settings{..} Nothing =
, uNoNetwork = Just noNetwork
, uKeyBindings = Nothing
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
}
fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings
@ -342,6 +344,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uNoNetwork = Just noNetwork
, uKeyBindings = Just ukb
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
}
data UserKeyBindings = UserKeyBindings
@ -415,6 +418,7 @@ data Settings = Settings
, verbose :: Bool
, urlSource :: URLSource
, noNetwork :: Bool
, gpgSetting :: GPGSetting
}
deriving (Show, GHC.Generic)
@ -448,6 +452,13 @@ data Downloader = Curl
instance NFData Downloader
data GPGSetting = GPGStrict
| GPGLax
| GPGNone
deriving (Eq, Show, Ord, GHC.Generic)
instance NFData GPGSetting
data DebugInfo = DebugInfo
{ diBaseDir :: FilePath
, diBinDir :: FilePath

1
lib/GHCup/Types/JSON.hs
View File

@ -54,6 +54,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
instance ToJSON Tag where
toJSON Latest = String "Latest"

6
lib/GHCup/Utils.hs
View File

@ -1031,7 +1031,7 @@ ensureGlobalTools :: ( MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Excepts '[DigestError , DownloadFailed, NoDownload] m ()
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
ensureGlobalTools = do
#if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
@ -1043,8 +1043,8 @@ ensureGlobalTools = do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
pure ()
#else
pure ()