From 41d44b037d4c1c94b03547aa7cceaced47c28913 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 2 Sep 2023 18:21:22 +0800 Subject: [PATCH] Validate gpg sig even if using file:// yaml url --- lib/GHCup/Download.hs | 80 ++++++++++++++++++++++++++++--------------- lib/GHCup/Utils.hs | 2 +- 2 files changed, 53 insertions(+), 29 deletions(-) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 418beb5..0713540 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -246,7 +246,7 @@ getBase uri = do Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time - if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True + if | scheme == "file" -> liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing (fromGHCupPath cacheDir) Nothing True | e -> do accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime @@ -352,15 +352,20 @@ download :: ( MonadReader env m download rawUri gpgUri eDigest eCSize dest mfn etags | scheme == "https" = liftE dl | scheme == "http" = liftE dl + | scheme == "file" + , Just s <- gpgScheme + , s /= "file" = throwIO $ userError $ "gpg scheme does not match base file scheme: " <> (T.unpack . decUTF8Safe $ s) | scheme == "file" = do + Settings{ gpgSetting } <- lift getSettings let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri lift $ logDebug $ "using local file: " <> T.pack destFile' - forM_ eDigest (liftE . flip checkDigest destFile') + liftE $ verify gpgSetting destFile' (pure . T.unpack . decUTF8Safe . view pathL') pure destFile' | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) where - scheme = view (uriSchemeL' % schemeBSL') rawUri + scheme = view (uriSchemeL' % schemeBSL') rawUri + gpgScheme = view (uriSchemeL' % schemeBSL') <$> gpgUri dl = do Settings{ mirrors } <- lift getSettings let uri = applyMirrors mirrors rawUri @@ -402,30 +407,14 @@ download rawUri gpgUri eDigest eCSize dest mfn etags 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 (prettyHFError (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_ eCSize (liftE . flip checkCSize baseDestFile) - forM_ eDigest (liftE . flip checkDigest baseDestFile) + liftE $ verify gpgSetting baseDestFile + (\uri' -> do + gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri' Nothing + lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri' <> " as file " <> T.pack gpgDestFile + flip onException (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) $ + downloadAction gpgDestFile uri' + pure gpgDestFile + ) pure baseDestFile curlDL :: ( MonadCatch m @@ -623,6 +612,41 @@ download rawUri gpgUri eDigest eCSize dest mfn etags liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp) pure Nothing + verify :: ( MonadReader env m + , HasLog env + , HasDirs env + , HasSettings env + , MonadCatch m + , MonadMask m + , MonadIO m + ) + => GPGSetting + -> FilePath + -> (URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m FilePath) + -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m () + verify gpgSetting destFile' downloadAction' = do + case (gpgUri, gpgSetting) of + (_, GPGNone) -> pure () + (Just gpgUri', _) -> do + liftE $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError] + (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e)) + ) $ do + o' <- liftIO getGpgOpts + gpgDestFile <- liftE $ downloadAction' gpgUri' + lift $ logInfo $ "verifying signature of: " <> T.pack destFile' + let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, destFile'] + 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_ eCSize (liftE . flip checkCSize destFile') + forM_ eDigest (liftE . flip checkDigest destFile') + + -- | Download into tmpdir or use cached version, if it exists. If filename -- is omitted, infers the filename from the url. @@ -642,7 +666,7 @@ downloadCached :: ( MonadReader env m downloadCached dli mfn = do Settings{ cache } <- lift getSettings case cache of - True -> downloadCached' dli mfn Nothing + True -> liftE $ downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 16259b9..099e5d2 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1033,7 +1033,7 @@ applyPatches pdir ddir = do patches <- liftIO $ quilt `catchIO` (\e -> if isDoesNotExistError e || isPermissionError e then - lexicographical + lexicographical else throwIO e) forM_ patches $ \patch' -> applyPatch patch' ddir