Skip to content

Commit

Permalink
Validate gpg sig even if using file:// yaml url
Browse files Browse the repository at this point in the history
  • Loading branch information
hasufell committed Sep 3, 2023
1 parent 50252d8 commit 03253c2
Show file tree
Hide file tree
Showing 2 changed files with 53 additions and 29 deletions.
80 changes: 52 additions & 28 deletions lib/GHCup/Download.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand All @@ -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
Expand Down
2 changes: 1 addition & 1 deletion lib/GHCup/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down

0 comments on commit 03253c2

Please sign in to comment.