Validate gpg sig even if using file:// yaml url

app/ghcup/BrickMain.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ViewPatterns      #-}
-{-# LANGUAGE TemplateHaskell   #-}
 
 module BrickMain where
 
@@ -26,7 +25,6 @@ import           Brick
 import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Center
-import           Brick.Widgets.Dialog (buttonSelectedAttr)
 import           Brick.Widgets.List             ( listSelectedFocusedAttr
                                                 , listSelectedAttr
                                                 , listAttr
@@ -43,11 +41,11 @@ import           Data.Bool
 import           Data.Functor
 import           Data.List
 import           Data.Maybe
-import           Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
+import           Data.IORef
 import           Data.Vector                    ( Vector
                                                 , (!?)
                                                 )
-import           Data.Versions           hiding ( str, Lens' )
+import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( appendFile )
 import           System.FilePath
@@ -63,84 +61,68 @@ import qualified Graphics.Vty                  as Vty
 import qualified Data.Vector                   as V
 import System.Environment (getExecutablePath)
 import qualified System.Posix.Process          as SPP
-import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ( (.=), use, (%=), view )
-import Lens.Micro ((.~), (&))
+
 
 hiddenTools :: [Tool]
-hiddenTools = [] 
+hiddenTools = []
+
 
 data BrickData = BrickData
-  { _lr    :: [ListResult]
+  { lr    :: [ListResult]
   }
   deriving Show
 
-makeLenses ''BrickData
-
 data BrickSettings = BrickSettings
-  { _showAllVersions    :: Bool
-  , _showAllTools       :: Bool
+  { showAllVersions    :: Bool
+  , showAllTools       :: Bool
   }
-  --deriving Show
-
-makeLenses ''BrickSettings
+  deriving Show
 
 data BrickInternalState = BrickInternalState
-  { _clr   :: Vector ListResult
-  , _ix    :: Int
+  { clr :: Vector ListResult
+  , ix  :: Int
   }
-  --deriving Show
-
-makeLenses ''BrickInternalState
+  deriving Show
 
 data BrickState = BrickState
-  { _appData     :: BrickData
-  , _appSettings :: BrickSettings
-  , _appState    :: BrickInternalState
-  , _appKeys     :: KeyBindings
+  { appData     :: BrickData
+  , appSettings :: BrickSettings
+  , appState    :: BrickInternalState
+  , appKeys     :: KeyBindings
   }
-  --deriving Show
+  deriving Show
 
-makeLenses ''BrickState
 
 keyHandlers :: KeyBindings
             -> [ ( Vty.Key
                  , BrickSettings -> String
-                 , EventM String BrickState ()
+                 , BrickState -> EventM String BrickState ()
                  )
                ]
 keyHandlers KeyBindings {..} =
-  [ (bQuit, const "Quit"     , halt)
+  [ (bQuit, const "Quit"     , \_ -> halt)
   , (bInstall, const "Install"  , withIOAction install')
   , (bUninstall, const "Uninstall", withIOAction del')
   , (bSet, const "Set"      , withIOAction set')
   , (bChangelog, const "ChangeLog", withIOAction changelog')
   , ( bShowAllVersions
     , \BrickSettings {..} ->
-       if _showAllVersions then "Don't show all versions" else "Show all versions"
-    , hideShowHandler' (not . _showAllVersions) _showAllTools
+       if showAllVersions then "Don't show all versions" else "Show all versions"
+    , hideShowHandler (not . showAllVersions) showAllTools
     )
   , ( bShowAllTools
     , \BrickSettings {..} ->
-       if _showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler' _showAllVersions (not . _showAllTools)
+       if showAllTools then "Don't show all tools" else "Show all tools"
+    , hideShowHandler showAllVersions (not . showAllTools)
     )
-  , (bUp, const "Up", appState %= moveCursor 1 Up)
-  , (bDown, const "Down", appState %= moveCursor 1 Down)
+  , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
+  , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
   ]
  where
-  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
-  hideShowHandler' f p = do 
-    app_settings <- use appSettings
-    let 
-      vers = f app_settings
-      tools = p app_settings
-      newAppSettings = app_settings & showAllVersions .~ vers & showAllTools .~ tools
-    ad <- use appData
-    current_app_state <- use appState
-    appSettings .= newAppSettings
-    appState    .= constructList ad app_settings (Just current_app_state)
-
+  hideShowHandler f p BrickState{..} =
+    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+        newInternalState = constructList appData newAppSettings (Just appState)
+    in  put (BrickState appData newAppSettings newInternalState appKeys)
 
 
 showKey :: Vty.Key -> String
@@ -149,12 +131,13 @@ showKey Vty.KUp = "↑"
 showKey Vty.KDown = "↓"
 showKey key = tail (show key)
 
+
 ui :: AttrMap -> BrickState -> Widget String
-ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
+ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
   = padBottom Max
       ( withBorderStyle unicode
         $ borderWithLabel (str "GHCup")
-          (center (header <=> hBorder <=> renderList' _appState))
+          (center (header <=> hBorder <=> renderList' appState))
       )
     <=> footer
 
@@ -165,7 +148,7 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
       . T.pack
       . foldr1 (\x y -> x <> "  " <> y)
       . fmap (\(key, s, _) -> showKey key <> ":" <> s as)
-      $ keyHandlers _appKeys
+      $ keyHandlers appKeys
   header =
     minHSize 2 emptyWidget
       <+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
@@ -173,8 +156,8 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
       <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
       <+> padLeft (Pad 5) (str "Notes")
   renderList' bis@BrickInternalState{..} =
-    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) _clr
-        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) _clr
+    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
+        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
     in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
   renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
     let marks = if
@@ -280,10 +263,11 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
 minHSize :: Int -> Widget n -> Widget n
 minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
 
-app :: AttrMap -> AttrMap -> App BrickState () String
+
+app :: AttrMap -> AttrMap -> App BrickState e String
 app attrs dimAttrs =
-  App { appDraw     = \st -> [ui dimAttrs st]
-  , appHandleEvent  = eventHandler
+  App { appDraw         = \st -> [ui dimAttrs st]
+  , appHandleEvent  = \be -> get >>= \s -> eventHandler s be
   , appStartEvent   = return ()
   , appAttrMap      = const attrs
   , appChooseCursor = showFirstCursor
@@ -308,7 +292,6 @@ defaultAttributes no_color = attrMap
   , (attrName "day"               , Vty.defAttr `withForeColor` Vty.blue)
   , (attrName "help"              , Vty.defAttr `withStyle`     Vty.italic)
   , (attrName "hooray"            , Vty.defAttr `withForeColor` Vty.brightWhite)
-  , (buttonSelectedAttr           , Vty.defAttr `withBackColor` Vty.brightWhite)
   ]
   where
     withForeColor | no_color  = const
@@ -329,51 +312,56 @@ dimAttributes no_color = attrMap
     withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
                   | otherwise = Vty.withBackColor
 
-eventHandler :: BrickEvent String e -> EventM String BrickState ()
-eventHandler ev = do
+eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
+eventHandler st@BrickState{..} ev = do
   AppState { keyBindings = kb } <- liftIO $ readIORef settings'
   case ev of
-    (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
-    (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
-    (VtyEvent (Vty.EvResize _ _)) -> pure ()
-    (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
-    (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
+    (MouseDown _ Vty.BScrollUp _ _) ->
+      put (BrickState { appState = moveCursor 1 appState Up, .. })
+    (MouseDown _ Vty.BScrollDown _ _) ->
+      put (BrickState { appState = moveCursor 1 appState Down, .. })
+    (VtyEvent (Vty.EvResize _ _)) -> put st
+    (VtyEvent (Vty.EvKey Vty.KUp _)) ->
+      put BrickState{ appState = moveCursor 1 appState Up, .. }
+    (VtyEvent (Vty.EvKey Vty.KDown _)) ->
+      put BrickState{ appState = moveCursor 1 appState Down, .. }
     (VtyEvent (Vty.EvKey key _)) ->
       case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
-        Nothing -> pure ()
-        Just (_, _, handler) -> handler
-    _ -> pure ()
+        Nothing -> put st
+        Just (_, _, handler) -> handler st
+    _ -> put st
 
 
-moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
-moveCursor steps direction ais@BrickInternalState{..} =
-  let newIx = if direction == Down then _ix + steps else _ix - steps
-  in  case _clr !? newIx of
-        Just _  -> ais & ix .~ newIx
+moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
+moveCursor steps ais@BrickInternalState{..} direction =
+  let newIx = if direction == Down then ix + steps else ix - steps
+  in  case clr !? newIx of
+        Just _  -> BrickInternalState { ix = newIx, .. }
         Nothing -> ais
 
 
 -- | Suspend the current UI and run an IO action in terminal. If the
 -- IO action returns a Left value, then it's thrown as userError.
 withIOAction :: Ord n
-             => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
+             => (BrickState
+                 -> (Int, ListResult)
+                 -> ReaderT AppState IO (Either String a))
+             -> BrickState
              -> EventM n BrickState ()
-withIOAction action = do
-  as <- get
-  case listSelectedElement' (view appState as) of
-    Nothing      -> pure ()
-    Just (curr_ix, e) -> do
-      suspendAndResume $ do
-        settings <- readIORef settings'
-        flip runReaderT settings $ action (curr_ix, e) >>= \case
-          Left  err -> liftIO $ putStrLn ("Error: " <> err)
-          Right _   -> liftIO $ putStrLn "Success"
-        getAppData Nothing >>= \case
-          Right data' -> do
-            putStrLn "Press enter to continue"
-            _ <- getLine
-            pure (updateList data' as)
-          Left err -> throwIO $ userError err
+withIOAction action as = case listSelectedElement' (appState as) of
+  Nothing      -> put as
+  Just (ix, e) -> do
+    suspendAndResume $ do
+      settings <- readIORef settings'
+      flip runReaderT settings $ action as (ix, e) >>= \case
+        Left  err -> liftIO $ putStrLn ("Error: " <> err)
+        Right _   -> liftIO $ putStrLn "Success"
+      getAppData Nothing >>= \case
+        Right data' -> do
+          putStrLn "Press enter to continue"
+          _ <- getLine
+          pure (updateList data' as)
+        Left err -> throwIO $ userError err
 
 
 -- | Update app data and list internal state based on new evidence.
@@ -381,11 +369,11 @@ withIOAction action = do
 -- and @BrickSettings@.
 updateList :: BrickData -> BrickState -> BrickState
 updateList appD BrickState{..} =
-  let newInternalState = constructList appD _appSettings (Just _appState)
-  in  BrickState { _appState    = newInternalState
-                 , _appData     = appD
-                 , _appSettings = _appSettings
-                 , _appKeys     = _appKeys
+  let newInternalState = constructList appD appSettings (Just appState)
+  in  BrickState { appState    = newInternalState
+                 , appData     = appD
+                 , appSettings = appSettings
+                 , appKeys     = appKeys
                  }
 
 
@@ -394,12 +382,12 @@ constructList :: BrickData
               -> Maybe BrickInternalState
               -> BrickInternalState
 constructList appD appSettings =
-  replaceLR (filterVisible (_showAllVersions appSettings)
-                           (_showAllTools appSettings))
-            (_lr appD)
+  replaceLR (filterVisible (showAllVersions appSettings)
+                           (showAllTools appSettings))
+            (lr appD)
 
 listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
-listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix
+listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
 
 
 selectLatest :: Vector ListResult -> Int
@@ -445,9 +433,10 @@ filterVisible v t e | lInstalled e = True
 
 
 install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-         => (Int, ListResult)
+         => BrickState
+         -> (Int, ListResult)
          -> m (Either String ())
-install' (_, ListResult {..}) = do
+install' _ (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run =
@@ -521,9 +510,10 @@ install' (_, ListResult {..}) = do
 
 
 set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => (Int, ListResult)
+     => BrickState
+     -> (Int, ListResult)
      -> m (Either String ())
-set' input@(_, ListResult {..}) = do
+set' bs input@(_, ListResult {..}) = do
   settings <- liftIO $ readIORef settings'
 
   let run =
@@ -545,12 +535,12 @@ set' input@(_, ListResult {..}) = do
               promptAnswer <- getUserPromptResponse userPrompt
               case promptAnswer of
                 PromptYes -> do
-                  res <- install' input
+                  res <- install' bs input
                   case res of
                     (Left err) -> pure $ Left err
                     (Right _) -> do
                       logInfo "Setting now..."
-                      set' input
+                      set' bs input
 
                 PromptNo -> pure $ Left (prettyHFError e)
               where
@@ -565,9 +555,10 @@ set' input@(_, ListResult {..}) = do
 
 
 del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => (Int, ListResult)
+     => BrickState
+     -> (Int, ListResult)
      -> m (Either String ())
-del' (_, ListResult {..}) = do
+del' _ (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run = runE @'[NotInstalled, UninstallFailed]
@@ -591,9 +582,10 @@ del' (_, ListResult {..}) = do
 
 
 changelog' :: (MonadReader AppState m, MonadIO m)
-           => (Int, ListResult)
+           => BrickState
+           -> (Int, ListResult)
            -> m (Either String ())
-changelog' (_, ListResult {..}) = do
+changelog' _ (_, ListResult {..}) = do
   AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
   case getChangeLog dls lTool (ToolVersion lVer) of
     Nothing -> pure $ Left $
@@ -626,6 +618,7 @@ settings' = unsafePerformIO $ do
                       loggerConfig
 
 
+
 brickMain :: AppState
           -> IO ()
 brickMain s = do
@@ -649,7 +642,7 @@ brickMain s = do
 
 
 defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
+defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
 
 
 getGHCupInfo :: IO (Either String GHCupInfo)
@@ -676,4 +669,3 @@ getAppData mgi = runExceptT $ do
   flip runReaderT settings $ do
     lV <- listVersions Nothing [] False True (Nothing, Nothing)
     pure $ BrickData (reverse lV)
-

docs/install.md

@@ -38,78 +38,49 @@ Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information
 
 ### Linux Debian
 
-#### Generic
-
 The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
 
-#### Version >= 11
-
-The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
 ### Linux Ubuntu
 
-#### Generic
-
 The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
 
-#### Version >= 20.04 && < 20.10
-
-The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
-#### Version >= 20.10
-
-The following distro packages are required: `build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
-
 ### Linux Fedora
 
-#### Generic
-
 The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
 
+### Linux Mageia
+
+The following distro packages are required: `curl gcc gcc-c++ gmp libffi-devel libffi7 libgmp-devel libgmp10 make libncurses-devel libncurses5 xz perl`
 
 ### Linux CentOS
 
-#### Generic
-
 The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
 
-#### Version >= 7 && < 8
-
-The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses xz perl`
-
-
 ### Linux Alpine
 
-#### Generic
-
 The following distro packages are required: `binutils-gold curl gcc g++ gmp-dev libc-dev libffi-dev make musl-dev ncurses-dev perl tar xz`
 
+### Linux VoidLinux
+
+The following distro packages are required: `gcc gmp curl coreutils xz ncurses make ncurses-libtinfo-libs perl tar`
 
 ### Linux (generic)
 
-#### Generic
-
 You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.
 
 ### Darwin
 
-#### Generic
-
 On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again.
 On Darwin M1 you might also need a working llvm installed (e.g. via brew) and have the toolchain exposed in PATH.
 
 ### FreeBSD
 
-#### Generic
-
 The following distro packages are required: `curl gcc gmp gmake ncurses perl5 libffi libiconv`
 
+Notice that only FreeBSD 13.x is supported. If the installation fails, complaining about `libncursesw.8.so`, you will need to install FreeBSD 12 compat package first, for example, `pkg install misc/compat12x`.
 
 ### Windows
 
-#### Generic
-
 On Windows, msys2 should already have been set up during the installation, so most users should just proceed. If you are installing manually, make sure to have a working mingw64 toolchain and shell.
 
 ## Next steps

ghcup.cabal

@@ -352,9 +352,6 @@ executable ghcup
       , transformers  ^>=0.5
       , unix          ^>=2.7
       , vty           ^>=5.37
-      , microlens     ^>=0.4.13
-      , microlens-th  ^>=0.4.3
-      , microlens-mtl ^>=0.2.0
 
   if os(windows)
     cpp-options: -DIS_WINDOWS

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

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