slackbuilder/lib/SlackBuilder/Download.hs

361 lines
14 KiB
Haskell
Raw Normal View History

2023-12-23 22:15:10 +01:00
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-- | Contains routines for downloading, cloning and uploading sources.
2023-08-15 10:33:19 +02:00
module SlackBuilder.Download
( cloneAndUpload
, extractRemote
, commit
, createLzmaTarball
2023-08-21 13:38:20 +02:00
, download
, hostedSources
, remoteFileExists
2024-01-24 14:34:58 +01:00
, responseBodySource
, reqGet
, sinkFileAndHash
2024-01-24 14:34:58 +01:00
, sinkHash
2023-08-15 10:33:19 +02:00
, updateSlackBuildVersion
2024-05-11 19:01:41 +02:00
, uploadSource
2023-08-15 10:33:19 +02:00
) where
2024-08-08 11:03:02 +02:00
import qualified Codec.Compression.Lzma as Lzma
2023-08-21 13:38:20 +02:00
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
2024-05-11 19:01:41 +02:00
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
2024-08-08 11:03:02 +02:00
import Data.NonNull (toNullable)
2024-03-03 17:12:29 +01:00
import Data.Foldable (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
2023-08-15 10:33:19 +02:00
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import SlackBuilder.Config
import SlackBuilder.Trans
import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(liftIO))
import System.Directory (createDirectory, removePathForcibly)
2023-08-15 10:33:19 +02:00
import System.IO (IOMode(..), withFile)
2024-03-03 17:12:29 +01:00
import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, stripExtension)
2023-08-21 13:38:20 +02:00
import System.Process
( CreateProcess(..)
, StdStream(..)
, proc
, readCreateProcessWithExitCode
, callProcess
)
2023-08-15 10:33:19 +02:00
import System.Exit (ExitCode(..))
import Control.Monad (unless, void)
import Text.URI (URI(..))
import qualified Text.URI as URI
import Network.HTTP.Req
( useHttpsURI
2024-09-20 17:52:09 +02:00
, useURI
, HEAD(..)
, NoReqBody(..)
, req
, runReq
, defaultHttpConfig
, ignoreResponse
2023-08-21 13:38:20 +02:00
, responseStatusCode
, MonadHttp
2023-08-21 13:38:20 +02:00
, HttpConfig(..)
, GET(..)
, reqBr
)
import Data.Functor ((<&>))
2023-08-21 13:38:20 +02:00
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
( ConduitT
, MonadResource
2023-08-21 13:38:20 +02:00
, yield
, runConduitRes
, sinkFile
, (.|)
, ZipSink(..)
, await
, sourceFile
, leftover
, awaitNonNull
2023-08-21 13:38:20 +02:00
)
import Data.Conduit.Tar (FileInfo(..), tarFilePath, untar)
2023-08-21 13:38:20 +02:00
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
2024-03-03 17:12:29 +01:00
import qualified Data.Conduit.Zlib as Zlib
import Control.Monad.Catch (MonadThrow(..))
import Data.Maybe (fromMaybe)
2023-08-15 10:33:19 +02:00
updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT ()
updateSlackBuildVersion packagePath version additionalDownloads = do
2023-08-15 10:33:19 +02:00
repository' <- SlackBuilderT $ asks repository
let name = Text.unpack $ snd $ Text.breakOnEnd "/" packagePath
slackbuildFilename = repository'
</> Text.unpack packagePath
</> (name <.> "SlackBuild")
slackbuildContents <- liftIO $ Text.IO.readFile slackbuildFilename
let slackbuildLines = replaceLine . updateLineVariable "VERSION" version
<$> Text.lines slackbuildContents
2023-08-15 10:33:19 +02:00
liftIO $ Text.IO.writeFile slackbuildFilename $ Text.unlines slackbuildLines
where
replaceLine line = Map.foldrWithKey updateLineDependencyVersion line additionalDownloads
updateLineDependencyVersion dependencyName = updateLineVariable
$ dependencyName <> "_VERSION"
updateLineVariable variableName variableValue line
2023-11-07 19:36:40 +01:00
| Text.isPrefixOf (variableName <> "=") line =
variableName <> "=${" <> variableName <> ":-" <> variableValue <> "}"
| otherwise = line
2023-08-15 10:33:19 +02:00
commit :: Text -> Text -> SlackBuilderT ()
commit packagePath version = do
branch' <- SlackBuilderT $ Text.unpack <$> asks branch
repository' <- SlackBuilderT $ asks repository
signature' <- SlackBuilderT $ asks $ signature . maintainer
2023-08-15 10:33:19 +02:00
let message = Text.unpack
$ packagePath <> ": Updated for version " <> version
mainCommitArguments = ["-C", repository', "commit", "-m", message]
commitArguments =
if signature'
then mainCommitArguments <> ["-S"]
else mainCommitArguments
2023-08-15 10:33:19 +02:00
(checkoutExitCode, _, _) <- liftIO
$ withFile "/dev/null" WriteMode
$ testCheckout repository' branch'
unless (checkoutExitCode == ExitSuccess)
$ liftIO
$ callProcess "git" ["-C", repository', "checkout", "-b", branch', "master"]
liftIO
$ callProcess "git" ["-C", repository', "add", Text.unpack packagePath]
>> callProcess "git" commitArguments
2023-08-15 10:33:19 +02:00
where
testCheckout repository' branch' nullHandle =
let createCheckoutProcess = (proc "git" ["-C", repository', "checkout", branch'])
{ std_in = NoStream
, std_err = UseHandle nullHandle
}
in readCreateProcessWithExitCode createCheckoutProcess ""
2024-05-13 18:26:23 +02:00
hostedSources :: NonEmpty Text -> SlackBuilderT URI
hostedSources urlPathPieces = do
downloadURL' <- SlackBuilderT (asks downloadURL) >>= URI.mkURI
urlPathPieces' <- traverse URI.mkPathPiece urlPathPieces
2024-05-13 18:26:23 +02:00
let updatedPath = case URI.uriPath downloadURL' of
Just (_, existingPath) ->
NonEmpty.append existingPath urlPathPieces'
Nothing -> urlPathPieces'
pure $ downloadURL'{ uriPath = Just (False, updatedPath) }
remoteFileExists :: NonEmpty Text -> SlackBuilderT Bool
remoteFileExists urlPathPieces = hostedSources urlPathPieces
>>= traverse (runReq httpConfig . go . fst) . useHttpsURI
<&> maybe False ((== 200) . responseStatusCode)
where
httpConfig = defaultHttpConfig
{ httpConfigCheckResponse = const $ const $ const Nothing
}
go uri = req HEAD uri NoReqBody ignoreResponse mempty
cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT ()
cloneAndArchive repo tarballPath tagPrefix = do
let version = snd $ Text.breakOnEnd "-"
$ Text.pack $ takeFileName tarballPath
repositoryTarballPath <- relativeToRepository tarballPath
repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
liftIO
$ removePathForcibly repositoryTarballPath
>> callProcess "git"
[ "clone"
, Text.unpack repo
, repositoryTarballPath
]
>> callProcess "git"
[ "-C"
, repositoryTarballPath
, "checkout"
, Text.unpack $ tagPrefix <> version
]
>> callProcess "git"
[ "-C"
, repositoryTarballPath
, "submodule"
, "update"
, "--init"
, "--recursive"
]
>> createLzmaTarball repositoryTarballPath repositoryArchivePath
>> removePathForcibly repositoryTarballPath
2024-05-25 07:54:05 +02:00
-- | Takes a directory as input and a file name as output and creates a tar.xz
-- archive from the given directory.
createLzmaTarball :: FilePath -> FilePath -> IO (Digest MD5)
createLzmaTarball input output = runConduitRes $ yield input
.| void tarFilePath
2024-08-08 11:03:02 +02:00
.| compressLzma
.| sinkFileAndHash output
2023-08-21 13:38:20 +02:00
responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m ()
responseBodySource = bodyReaderSource . responseBody
where
bodyReaderSource br = liftIO (brRead br) >>= go br
go br bs = unless (ByteString.null bs) $ yield bs >> bodyReaderSource br
sinkHash :: Monad m => ConduitT ByteString Void m (Digest MD5)
sinkHash = sink hashInit
where
sink ctx = await
>>= maybe (pure $ hashFinalize ctx) (sink . hashUpdate ctx)
cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (URI, Digest MD5)
cloneAndUpload repo tarballPath tagPrefix = do
2024-05-13 18:26:23 +02:00
let tarballFileName = takeFileName tarballPath <.> "tar.xz"
packageName = takeFileName $ takeDirectory tarballPath
remoteArchivePath = Text.pack $ packageName </> tarballFileName
urlPathPieces = Text.pack <$> packageName :| [tarballFileName]
localPath <- relativeToRepository tarballFileName
remoteResultURI <- hostedSources urlPathPieces
remoteFileExists' <- remoteFileExists urlPathPieces
2023-08-25 10:30:24 +02:00
if remoteFileExists'
then (remoteResultURI,) . snd
<$> download remoteResultURI (takeDirectory localPath)
2023-08-25 10:30:24 +02:00
else
let go = sourceFile localPath .| sinkHash
in cloneAndArchive repo tarballPath tagPrefix
2024-05-11 19:01:41 +02:00
>> uploadSource localPath remoteArchivePath
>> liftIO (runConduitRes go) <&> (remoteResultURI,)
2024-03-05 23:06:32 +01:00
-- | Given a path to a local file and a remote path uploads the file using
-- the settings given in the configuration file.
--
-- The remote path is given relative to the path in the configuration.
2024-05-11 19:01:41 +02:00
uploadSource :: FilePath -> Text -> SlackBuilderT ()
uploadSource localPath remotePath' = do
uploadCommand' :| uploadArguments <- SlackBuilderT $ asks uploadCommand
let uploadArguments' = Text.unpack
. Text.replace "%s" (Text.pack localPath)
. Text.replace "%c" remotePath'
<$> uploadArguments
liftIO $ callProcess (Text.unpack uploadCommand') uploadArguments'
2024-03-05 23:06:32 +01:00
-- | 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
2024-09-20 17:52:09 +02:00
| otherwise = throwM $ UnsupportedUrlType 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
.| sinkFileAndHash target
pure (targetFileName, digest)
-- | Writes a file to the destination path and accumulates its MD5 checksum.
sinkFileAndHash :: MonadResource m => FilePath -> ConduitT ByteString Void m (Digest MD5)
sinkFileAndHash target = getZipSink
$ ZipSink (sinkFile target) *> ZipSink sinkHash
2024-08-08 11:03:02 +02:00
compressLzma :: MonadIO m => ConduitT ByteString ByteString m ()
compressLzma = liftIO (Lzma.compressIO Lzma.defaultCompressParams) >>= go
where
go (Lzma.CompressInputRequired flush supplyInput) = do
next <- await
result <- case next of
Just input
| ByteString.null input -> liftIO flush
| otherwise -> liftIO $ supplyInput input
Nothing -> liftIO $ supplyInput mempty
go result
go (Lzma.CompressOutputAvailable output stream) = yield output
>> liftIO stream >>= go
go Lzma.CompressStreamEnd = pure ()
decompressLzma :: (MonadThrow m, MonadIO m) => ConduitT ByteString ByteString m ()
decompressLzma = liftIO (Lzma.decompressIO Lzma.defaultDecompressParams) >>= go
where
go (Lzma.DecompressInputRequired processor) = do
next <- awaitNonNull
result <- case next of
Just input -> liftIO $ processor (toNullable input)
Nothing -> liftIO $ processor mempty
go result
go (Lzma.DecompressOutputAvailable output stream) = yield output
>> liftIO stream
>>= go
go (Lzma.DecompressStreamEnd output) = leftover output
go (Lzma.DecompressStreamError lzmaReturn) = throwM
$ LzmaDecompressionFailed lzmaReturn
2024-03-03 17:12:29 +01:00
-- | Downloads a compressed tar archive and extracts its contents on the fly to
-- a directory.
--
-- If the download contains the disposition header and the attachment type was
-- 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 -> FilePath -> SlackBuilderT (Maybe FilePath)
extractRemote uri' packagePath =
runReq defaultHttpConfig $ go packagePath
where
go toTarget = reqGet uri' $ readResponse toTarget
readResponse :: FilePath -> Response BodyReader -> IO (Maybe FilePath)
2024-03-03 17:12:29 +01:00
readResponse toTarget response = do
let attachmentName = dispositionAttachment response
2024-03-03 17:12:29 +01:00
(decompress, attachmentDirectory) =
case attachmentName of
Just attachmentName'
| Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
(Zlib.ungzip, Just directoryName')
| Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
2024-08-08 11:03:02 +02:00
(decompressLzma, Just directoryName')
2024-03-03 17:12:29 +01:00
_ -> (pure (), Nothing)
runConduitRes $ responseBodySource response
.| decompress
.| untar (withDecompressedFile toTarget)
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
2024-09-20 17:52:09 +02:00
reqGet uri bodyReader =
case useURI uri of
Just urlWithOptions
| Left (httpsURI, httpsOptions) <- urlWithOptions ->
reqBr GET httpsURI NoReqBody httpsOptions bodyReader
| Right (httpsURI, httpsOptions) <- urlWithOptions ->
reqBr GET httpsURI NoReqBody httpsOptions bodyReader
_ -> throwM $ UnsupportedUrlType uri