summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/SlackBuilder/Download.hs90
-rw-r--r--src/Main.hs61
2 files changed, 94 insertions, 57 deletions
diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs
index 50eaff1..719efe9 100644
--- a/lib/SlackBuilder/Download.hs
+++ b/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
diff --git a/src/Main.hs b/src/Main.hs
index 92b27f4..c4967ba 100644
--- a/src/Main.hs
+++ b/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 ((<&>))
@@ -288,7 +288,7 @@ autoUpdatable =
dscannerURI = [uri|https://github.com/dlang-community/D-Scanner.git|]
in Map.fromList
[ ("DUB", latestDub)
- , ("DSCANNER", latestDscanner)
+ , ("DSCANNER", latestDscanner)
, ("DCD", latestDcd)
]
}
@@ -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
+
+ (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
- void $ extractRemote uri' packagePath
- download' <- handleReupload relativeTarball downloadFileName
- checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash
+ pure (checksum, relativeTarball)
+ download' <- handleReupload relativeTarball' downloadFileName
pure $ Package.Download download' checksum
where
name' = Text.pack $ takeBaseName $ Text.unpack packagePath
+ 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)
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
- 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
+ uploadCommand relativeTarball ("/" <> name')
+ liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> Text.pack downloadFileName
defaultCreateProcess cwd' cmdSpec
= flip withCreateProcess (const . const . const waitForProcess)
$ CreateProcess
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 20:35:37 +0000