slackbuilder/lib/SlackBuilder/Download.hs
Eugen Wissner ae63ff0cc0
All checks were successful
Build / audit (push) Successful in 7s
Build / test (push) Successful in 14m19s
Support HTTP and HTTPS URLs
2024-09-20 17:52:09 +02:00

359 lines
14 KiB
Haskell

{- 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.
module SlackBuilder.Download
( cloneAndUpload
, extractRemote
, commit
, createLzmaTarball
, download
, hostedSources
, remoteFileExists
, responseBodySource
, sinkFileAndHash
, sinkHash
, updateSlackBuildVersion
, uploadSource
) where
import qualified Codec.Compression.Lzma as Lzma
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.NonNull (toNullable)
import Data.Foldable (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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)
import System.IO (IOMode(..), withFile)
import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, stripExtension)
import System.Process
( CreateProcess(..)
, StdStream(..)
, proc
, readCreateProcessWithExitCode
, callProcess
)
import System.Exit (ExitCode(..))
import Control.Monad (unless, void)
import Text.URI (URI(..))
import qualified Text.URI as URI
import Network.HTTP.Req
( useHttpsURI
, useURI
, HEAD(..)
, NoReqBody(..)
, req
, runReq
, defaultHttpConfig
, ignoreResponse
, responseStatusCode
, MonadHttp
, HttpConfig(..)
, GET(..)
, reqBr
)
import Data.Functor ((<&>))
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
( ConduitT
, MonadResource
, yield
, runConduitRes
, sinkFile
, (.|)
, ZipSink(..)
, await
, sourceFile
, leftover, awaitNonNull
)
import Data.Conduit.Tar (FileInfo(..), tarFilePath, untar)
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
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
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
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
| Text.isPrefixOf (variableName <> "=") line =
variableName <> "=${" <> variableName <> ":-" <> variableValue <> "}"
| otherwise = line
commit :: Text -> Text -> SlackBuilderT ()
commit packagePath version = do
branch' <- SlackBuilderT $ Text.unpack <$> asks branch
repository' <- SlackBuilderT $ asks repository
signature' <- SlackBuilderT $ asks $ signature . maintainer
let message = Text.unpack
$ packagePath <> ": Updated for version " <> version
mainCommitArguments = ["-C", repository', "commit", "-m", message]
commitArguments =
if signature'
then mainCommitArguments <> ["-S"]
else mainCommitArguments
(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
where
testCheckout repository' branch' nullHandle =
let createCheckoutProcess = (proc "git" ["-C", repository', "checkout", branch'])
{ std_in = NoStream
, std_err = UseHandle nullHandle
}
in readCreateProcessWithExitCode createCheckoutProcess ""
hostedSources :: NonEmpty Text -> SlackBuilderT URI
hostedSources urlPathPieces = do
downloadURL' <- SlackBuilderT (asks downloadURL) >>= URI.mkURI
urlPathPieces' <- traverse URI.mkPathPiece urlPathPieces
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
-- | 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
.| compressLzma
.| sinkFileAndHash output
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
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
if remoteFileExists'
then (remoteResultURI,) . snd
<$> download remoteResultURI (takeDirectory localPath)
else
let go = sourceFile localPath .| sinkHash
in cloneAndArchive repo tarballPath tagPrefix
>> uploadSource localPath remoteArchivePath
>> liftIO (runConduitRes go) <&> (remoteResultURI,)
-- | 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.
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'
-- | 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 $ 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
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
-- | 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)
readResponse toTarget response = do
let attachmentName = dispositionAttachment response
(decompress, attachmentDirectory) =
case attachmentName of
Just attachmentName'
| Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
(Zlib.ungzip, Just directoryName')
| Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
(decompressLzma, Just directoryName')
_ -> (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
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