359 lines
14 KiB
Haskell
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
|