Fix error handling when we can't find a filename

app/ghcup-gen/Validate.hs

@@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                   ($(logError) $ T.pack $ prettyShow e)
                 liftIO $ exitWith (ExitFailure 2)
 
-    let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
+    let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
 
     r <-
       runLogger

lib/GHCup/Download.hs

@@ -172,31 +172,21 @@ getBase :: ( MonadReader env m
         -> Excepts '[JSONError] m GHCupInfo
 getBase uri = do
   Settings { noNetwork } <- lift getSettings
-
+  yaml <- lift $ yamlFromCache uri
-  -- try to download yaml... usually this writes it into cache dir,
+  unless noNetwork $
-  -- but in some cases not (e.g. when using file://), so we honour
+    handleIO (\e -> warnCache (displayException e))
-  -- the return filepath, if any
+      . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e))
-  mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
+      . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
-           then pure Nothing
+      . smartDl
-           else handleIO (\e -> warnCache (displayException e) >> pure Nothing)
+      $ uri
-               . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e) >> pure Nothing)
-               . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
-               . fmap Just
-               . smartDl
-               $ uri
-
-  -- if we didn't get a filepath from the download, use the cached yaml
-  actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
-  lift $ $(logDebug) [i|Decoding yaml at: #{actualYaml}|]
-
   liftE
-    . onE_ (onError actualYaml)
+    . onE_ (onError yaml)
     . lEM' @_ @_ @'[JSONError] JSONDecodeError
     . fmap (first (\e -> [i|#{displayException e}
-Consider removing "#{actualYaml}" manually.|]))
+Consider removing "#{yaml}" manually.|]))
     . liftIO
     . Y.decodeFileEither
-    $ actualYaml
+    $ yaml
  where
   -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
   -- may re-download and succeed.
@@ -231,32 +221,28 @@ Consider removing "#{actualYaml}" manually.|]))
                 , DigestError
                 ]
                m1
-               FilePath
+               ()
   smartDl uri' = do
     json_file <- lift $ yamlFromCache uri'
-    let scheme = view (uriSchemeL' % schemeBSL') uri'
     e <- liftIO $ doesFileExist json_file
     currentTime <- liftIO getCurrentTime
-    Dirs { cacheDir } <- lift getDirs
+    if e
+      then do
+        accessTime <- liftIO $ getAccessTime json_file
 
-       -- for local files, let's short-circuit and ignore access time
+        -- access time won't work on most linuxes, but we can try regardless
-    if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
+        when ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) $
-       | e -> do
+          -- no access in last 5 minutes, re-check upstream mod time
-          accessTime <- liftIO $ getAccessTime json_file
+          dlWithMod currentTime json_file
-
+      else
-          -- access time won't work on most linuxes, but we can try regardless
+        dlWithMod currentTime json_file
-          if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
-                -- no access in last 5 minutes, re-check upstream mod time
-                dlWithMod currentTime json_file
-             | otherwise -> pure json_file
-       | otherwise -> dlWithMod currentTime json_file
    where
     dlWithMod modTime json_file = do
       let (dir, fn) = splitFileName json_file
       f <- liftE $ download uri' Nothing dir (Just fn) True
       liftIO $ setModificationTime f modTime
       liftIO $ setAccessTime f modTime
-      pure f
+ 
 
 
 getDownloadInfo :: ( MonadReader env m
@@ -318,25 +304,28 @@ download :: ( MonadReader env m
             )
          => URI
          -> Maybe T.Text      -- ^ expected hash
-         -> FilePath          -- ^ destination dir (ignored for file:// scheme)
+         -> FilePath          -- ^ destination dir
          -> Maybe FilePath    -- ^ optional filename
          -> Bool              -- ^ whether to read an write etags
          -> Excepts '[DigestError , DownloadFailed] m FilePath
 download uri eDigest dest mfn etags
   | scheme == "https" = dl
   | scheme == "http"  = dl
-  | scheme == "file"  = do
+  | scheme == "file"  = cp
-      let destFile' = T.unpack . decUTF8Safe $ path
-      lift $ $(logDebug) [i|using local file: #{destFile'}|]
-      forM_ eDigest (liftE . flip checkDigest destFile')
-      pure destFile'
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
   scheme = view (uriSchemeL' % schemeBSL') uri
+  cp     = do
+    -- destination dir must exist
+    liftIO $ createDirRecursive' dest
+    let fromFile = T.unpack . decUTF8Safe $ path
+    destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
+    liftIO $ copyFile fromFile destFile
+    pure destFile
   dl = do
-    let uri' = decUTF8Safe (serializeURIRef' uri)
+    destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
-    lift $ $(logInfo) [i|downloading: #{uri'}|]
+    lift $ $(logInfo) [i|downloading: #{uri'} as file #{destFile}|]
 
     -- destination dir must exist
     liftIO $ createDirRecursive' dest
@@ -378,7 +367,7 @@ download uri eDigest dest mfn etags
                             _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
                               :: V '[MalformedHeaders]))
 
-                          writeEtags (parseEtags headers)
+                          writeEtags destFile (parseEtags headers)
                     else
                       liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
                         (o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -395,13 +384,13 @@ download uri eDigest dest mfn etags
                         case _exitCode of
                           ExitSuccess -> do
                             liftIO $ copyFile destFileTemp destFile
-                            writeEtags (parseEtags (decUTF8Safe' _stdErr))
+                            writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
                           ExitFailure i'
                             | i' == 8
                             , Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
                                      -> do
                                           $logDebug "Not modified, skipping download"
-                                          writeEtags (parseEtags (decUTF8Safe' _stdErr))
+                                          writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
                             | otherwise -> throwE (NonZeroExit i' "wget" opts)
                       else do
                         let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -416,10 +405,10 @@ download uri eDigest dest mfn etags
                       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 (pure $ Just etag))
+                        $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
                         $ do
                           r <- downloadToFile https host fullPath port destFile addHeaders
-                          writeEtags (pure $ decUTF8Safe <$> getHeader r "etag")
+                          writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
                     else void $ liftE $ catchE @HTTPNotModified
                                         @'[DownloadFailed]
                                    (\e@(HTTPNotModified _) ->
@@ -432,12 +421,18 @@ download uri eDigest dest mfn etags
 
 
   -- Manage to find a file we can write the body into.
-  destFile :: FilePath
+  getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
-  destFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
+  getDestFile = 
-                  (dest </>)
+    case mfn of
-                  mfn
+        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)
 
   parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
   parseEtags stderr = do
@@ -456,8 +451,8 @@ download uri eDigest dest mfn etags
         $logDebug "No etags header found"
         pure Nothing
 
-  writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => m (Maybe T.Text) -> m ()
+  writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
-  writeEtags getTags = do
+  writeEtags destFile getTags = do
     getTags >>= \case
       Just t -> do
         $logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]

lib/GHCup/Errors.hs

@@ -327,6 +327,15 @@ instance Pretty UnexpectedListLength where
 
 instance Exception UnexpectedListLength
 
+data NoUrlBase = NoUrlBase Text
+  deriving Show
+
+instance Pretty NoUrlBase where
+  pPrint (NoUrlBase url) =
+    text [i|Couldn't get a base filename from url #{url}|]
+
+instance Exception NoUrlBase
+
 
 
     ------------------------