Read the dispositon header when downloading

lib/SlackBuilder/Download.hs

@@ -18,6 +18,7 @@ module SlackBuilder.Download
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Char8 as Char8
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Foldable (find)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -40,7 +41,8 @@ import System.Process
     )
 import System.Exit (ExitCode(..))
 import Control.Monad (unless)
-import Text.URI (URI(..), mkURI)
+import Text.URI (URI(..))
+import qualified Text.URI as URI
 import Network.HTTP.Req
     ( useHttpsURI
     , HEAD(..)
@@ -52,7 +54,7 @@ import Network.HTTP.Req
     , responseStatusCode
     , HttpConfig(..)
     , GET(..)
-    , reqBr
+    , reqBr, MonadHttp
     )
 import Data.Functor ((<&>))
 import Network.HTTP.Client (BodyReader, Response(..), brRead)
@@ -72,6 +74,7 @@ import Data.Void (Void)
 import qualified Data.Conduit.Lzma as Lzma
 import qualified Data.Conduit.Zlib as Zlib
 import Control.Monad.Catch (MonadThrow(..))
+import Data.Maybe (fromMaybe)
 
 updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT ()
 updateSlackBuildVersion packagePath version additionalDownloads = do
@@ -127,7 +130,7 @@ commit packagePath version = do
 
 hostedSources :: Text -> SlackBuilderT URI
 hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
-    >>= liftIO . mkURI . (<> absoluteURL)
+    >>= liftIO . URI.mkURI . (<> absoluteURL)
 
 remoteFileExists :: Text -> SlackBuilderT Bool
 remoteFileExists url = hostedSources url
@@ -196,17 +199,7 @@ sinkHash = sink hashInit
     sink ctx = await
         >>= maybe (pure $ hashFinalize ctx) (sink . hashUpdate ctx)
 
-download :: URI -> FilePath -> SlackBuilderT (Maybe (Digest MD5))
-download uri target = traverse (runReq defaultHttpConfig . go . fst)
-    $ useHttpsURI uri
-  where
-    go uri' = reqBr GET uri' NoReqBody mempty readResponse
-    readResponse :: Response BodyReader -> IO (Digest MD5)
-    readResponse response = runConduitRes
-        $ responseBodySource response
-        .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)
-
-cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (Maybe (URI, Digest MD5))
+cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (URI, Digest MD5)
 cloneAndUpload repo tarballPath tagPrefix = do
     localPath <- relativeToRepository $ tarballPath <.> "tar.xz"
     let packageName = takeFileName $ takeDirectory tarballPath
@@ -216,12 +209,40 @@ cloneAndUpload repo tarballPath tagPrefix = do
     remoteFileExists' <- remoteFileExists remoteArchivePath
 
     if remoteFileExists'
-    then fmap (remoteResultURI,) <$> download remoteResultURI localPath
+    then (remoteResultURI,) . snd
+        <$> download remoteResultURI (takeDirectory localPath)
     else
         let go = sourceFile localPath .| sinkHash
          in cloneAndArchive repo tarballPath tagPrefix
             >> uploadCommand localPath remoteArchivePath
-            >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)
+            >> liftIO (runConduitRes go) <&> (remoteResultURI,)
+
+-- | Downlaods a file into the directory. Returns name of the downloaded file
+-- and checksum.
+--
+-- The filename is read from the disposition header or from the URL if the
+-- Content-Disposition is missing.
+download :: URI -> FilePath -> SlackBuilderT (FilePath, Digest MD5)
+download uri packagePath = runReq defaultHttpConfig go
+  where
+    go
+        | Just uriPath <- URI.uriPath uri =
+            reqGet uri
+                $ readResponse
+                $ Text.unpack
+                $ URI.unRText
+                $ NonEmpty.last
+                $ snd uriPath
+        | otherwise = throwM $ HttpsUrlExpected uri
+    readResponse :: FilePath -> Response BodyReader -> IO (FilePath, Digest MD5)
+    readResponse downloadFileName response = do
+        let attachmentName = dispositionAttachment response
+            targetFileName = fromMaybe downloadFileName attachmentName
+            target = packagePath </> fromMaybe downloadFileName attachmentName
+        digest <- runConduitRes
+            $ responseBodySource response
+            .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)
+        pure (targetFileName, digest)
 
 -- | Downloads a compressed tar archive and extracts its contents on the fly to
 -- a directory.
@@ -230,22 +251,14 @@ cloneAndUpload repo tarballPath tagPrefix = do
 -- recognized as tar archive, returns the attachment name from the
 -- disposition header without the extension. So if the disposition header
 -- is "attachment; filename=package-1.2.3.tar.gz", returns "package-1.2.3".
-extractRemote :: URI -> Text -> SlackBuilderT (Maybe Text)
-extractRemote uri' packagePath = do
-    repository' <- SlackBuilderT $ asks repository
-    let localToRepository = repository' </> Text.unpack packagePath
-    case useHttpsURI uri' of
-        Just (httpsURI, _httpsOptions) ->
-            runReq defaultHttpConfig $ go localToRepository httpsURI
-        Nothing -> throwM $ HttpsUrlExpected uri'
+extractRemote :: URI -> FilePath -> SlackBuilderT (Maybe FilePath)
+extractRemote uri' packagePath =
+    runReq defaultHttpConfig $ go packagePath
   where
-    go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget
-    readResponse :: FilePath -> Response BodyReader -> IO (Maybe Text)
+    go toTarget = reqGet uri' $ readResponse toTarget
+    readResponse :: FilePath -> Response BodyReader -> IO (Maybe FilePath)
     readResponse toTarget response = do
-        let attachmentName
-                = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
-                $ find ((== "Content-Disposition") . fst)
-                $ responseHeaders response
+        let attachmentName = dispositionAttachment response
             (decompress, attachmentDirectory) =
                 case attachmentName of
                     Just attachmentName'
@@ -257,8 +270,23 @@ extractRemote uri' packagePath = do
         runConduitRes $ responseBodySource response
             .| decompress
             .| untar (withDecompressedFile toTarget)
-        pure $ Text.pack <$> attachmentDirectory
+        pure attachmentDirectory
     withDecompressedFile toTarget FileInfo{..}
         | Char8.last filePath /= '/' =
             sinkFile (toTarget </> Char8.unpack filePath)
         | otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))
+
+dispositionAttachment :: Response BodyReader -> Maybe FilePath
+dispositionAttachment response
+    = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
+    $ find ((== "Content-Disposition") . fst)
+    $ responseHeaders response
+
+reqGet :: (MonadThrow m, MonadHttp m)
+    => URI
+    -> (Response BodyReader -> IO a)
+    -> m a
+reqGet uri bodyReader
+    | Just (httpsURI, httpsOptions) <- useHttpsURI uri =
+        reqBr GET httpsURI NoReqBody httpsOptions bodyReader
+    | otherwise = throwM $ HttpsUrlExpected uri

src/Main.hs

@@ -12,7 +12,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.IO.Class (MonadIO(..))
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, fromMaybe)
 import qualified Data.Map as Map
 import Options.Applicative (execParser)
 import SlackBuilder.CommandLine
@@ -61,7 +61,7 @@ import System.Console.ANSI
     , ConsoleLayer(..)
     )
 import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive)
-import Control.Monad (filterM, void)
+import Control.Monad (filterM)
 import Data.List (isPrefixOf, isSuffixOf, partition)
 import Conduit (runConduitRes, (.|), sourceFile)
 import Data.Functor ((<&>))
@@ -381,7 +381,7 @@ cloneFromGit repo tagPrefix packagePath version = do
             $ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo
         relativeTarball = Text.unpack packagePath
             </> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version)
-    (uri', checksum) <- fromJust <$> cloneAndUpload (URI.render repo) relativeTarball tagPrefix
+    (uri', checksum) <- cloneAndUpload (URI.render repo) relativeTarball tagPrefix
     pure $ Package.Download
         { md5sum = checksum
         , download = uri'
@@ -395,43 +395,52 @@ downloadWithTemplate downloadTemplate packagePath version = do
             $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
         relativeTarball = packagePath <> "/" <> downloadFileName
         tarball = repository' </> Text.unpack relativeTarball
-    checksum <- fromJust <$> download uri' tarball
-    pure $ Package.Download uri' checksum
+    checksum <- download uri' tarball
+    pure $ Package.Download uri' $ snd checksum
 
 reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download
 reuploadWithTemplate downloadTemplate commands packagePath version = do
     repository' <- SlackBuilderT $ asks repository
     uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
-    let downloadFileName = URI.unRText
+    let downloadFileName = Text.unpack
+            $ URI.unRText
             $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
-        relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName
-        tarball = repository' </> relativeTarball
+        packagePathRelativeToCurrent = repository' </> Text.unpack packagePath
 
-    void $ extractRemote uri' packagePath
-    download' <- handleReupload relativeTarball downloadFileName
-    checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash
+    (checksum, relativeTarball') <- case commands of
+        [] -> do
+            let relativeTarball = packagePathRelativeToCurrent
+                    </> downloadFileName
+            (downloadedFileName, checksum) <- download uri'
+                $ repository' </> relativeTarball
+            pure (checksum, packagePathRelativeToCurrent </> downloadedFileName)
+        _ -> do
+            changedArchiveRootName <- extractRemote uri' packagePathRelativeToCurrent
+            let relativeTarball = packagePathRelativeToCurrent
+                    </> fromMaybe downloadFileName changedArchiveRootName
+            prepareSource relativeTarball
+            checksum <- liftIO $ runConduitRes $ sourceFile relativeTarball .| sinkHash
 
+            pure (checksum, relativeTarball)
+
+    download' <- handleReupload relativeTarball' downloadFileName
     pure $ Package.Download download' checksum
   where
     name' = Text.pack $ takeBaseName $ Text.unpack packagePath
-    handleReupload relativeTarball downloadFileName = do
-        repository' <- SlackBuilderT $ asks repository
-        downloadURL' <- SlackBuilderT $ asks downloadURL
-
-        liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball
-        case commands of
-            [] -> uploadCommand relativeTarball ("/" <> name')
-            _ ->
-                let tarballPath = repository' </> relativeTarball
-                    packedDirectory = dropExtension $ dropExtension tarballPath
+    prepareSource tarballPath = do
+        let packedDirectory = dropExtension $ dropExtension tarballPath
          in liftIO (traverse (defaultCreateProcess packedDirectory) commands)
             >> liftIO
                 ( withCurrentDirectory (takeDirectory tarballPath)
                 $ callProcess "tar" ["Jcvf", takeFileName tarballPath, takeFileName packedDirectory]
                 )
             >> liftIO (removeDirectoryRecursive packedDirectory)
-                >> uploadCommand relativeTarball ("/" <> name')
-        liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> downloadFileName
+    handleReupload relativeTarball downloadFileName = do
+        downloadURL' <- SlackBuilderT $ asks downloadURL
+
+        liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball
+        uploadCommand relativeTarball ("/" <> name')
+        liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> Text.pack downloadFileName
     defaultCreateProcess cwd' cmdSpec
         = flip withCreateProcess (const . const . const waitForProcess)
         $ CreateProcess