265 lines
10 KiB
Haskell
265 lines
10 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/. -}
|
|
|
|
module SlackBuilder.Download
|
|
( cloneAndUpload
|
|
, extractRemote
|
|
, commit
|
|
, download
|
|
, hostedSources
|
|
, remoteFileExists
|
|
, responseBodySource
|
|
, sinkHash
|
|
, updateSlackBuildVersion
|
|
, uploadCommand
|
|
) where
|
|
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.ByteString.Char8 as Char8
|
|
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)
|
|
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)
|
|
import Text.URI (URI(..), mkURI)
|
|
import Network.HTTP.Req
|
|
( useHttpsURI
|
|
, HEAD(..)
|
|
, NoReqBody(..)
|
|
, req
|
|
, runReq
|
|
, defaultHttpConfig
|
|
, ignoreResponse
|
|
, responseStatusCode
|
|
, HttpConfig(..)
|
|
, GET(..)
|
|
, reqBr
|
|
)
|
|
import Data.Functor ((<&>))
|
|
import Network.HTTP.Client (BodyReader, Response(..), brRead)
|
|
import Conduit
|
|
( ConduitT
|
|
, yield
|
|
, runConduitRes
|
|
, sinkFile
|
|
, (.|)
|
|
, ZipSink(..)
|
|
, await
|
|
, sourceFile
|
|
)
|
|
import Data.Conduit.Tar (untar, FileInfo(..))
|
|
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
|
|
import Data.Void (Void)
|
|
import qualified Data.Conduit.Lzma as Lzma
|
|
import qualified Data.Conduit.Zlib as Zlib
|
|
import Control.Monad.Catch (MonadThrow(..))
|
|
|
|
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 :: Text -> SlackBuilderT URI
|
|
hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
|
|
>>= liftIO . mkURI . (<> absoluteURL)
|
|
|
|
remoteFileExists :: Text -> SlackBuilderT Bool
|
|
remoteFileExists url = hostedSources url
|
|
>>= 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
|
|
|
|
uploadCommand :: FilePath -> Text -> SlackBuilderT ()
|
|
uploadCommand localPath remotePath' = do
|
|
remoteRoot <- SlackBuilderT $ asks remotePath
|
|
localPathFromRepository <- relativeToRepository localPath
|
|
|
|
liftIO $ callProcess "scp"
|
|
[ localPathFromRepository
|
|
, Text.unpack $ remoteRoot <> remotePath'
|
|
]
|
|
|
|
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
|
|
$ callProcess "rm" ["-rf", 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"
|
|
]
|
|
>> callProcess "tar"
|
|
["Jcvf"
|
|
, repositoryArchivePath
|
|
, repositoryTarballPath
|
|
]
|
|
>> callProcess "rm" ["-rf", repositoryTarballPath]
|
|
|
|
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)
|
|
|
|
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 repo tarballPath tagPrefix = do
|
|
localPath <- relativeToRepository $ tarballPath <.> "tar.xz"
|
|
let packageName = takeFileName $ takeDirectory tarballPath
|
|
remoteArchivePath = Text.cons '/' $ Text.pack
|
|
$ packageName </> takeFileName tarballPath <.> "tar.xz"
|
|
remoteResultURI <- hostedSources remoteArchivePath
|
|
remoteFileExists' <- remoteFileExists remoteArchivePath
|
|
|
|
if remoteFileExists'
|
|
then fmap (remoteResultURI,) <$> download remoteResultURI localPath
|
|
else
|
|
let go = sourceFile localPath .| sinkHash
|
|
in cloneAndArchive repo tarballPath tagPrefix
|
|
>> uploadCommand localPath remoteArchivePath
|
|
>> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)
|
|
|
|
-- | 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 -> 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'
|
|
where
|
|
go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget
|
|
readResponse :: FilePath -> Response BodyReader -> IO (Maybe Text)
|
|
readResponse toTarget response = do
|
|
let attachmentName
|
|
= fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
|
|
$ find ((== "Content-Disposition") . fst)
|
|
$ responseHeaders response
|
|
(decompress, attachmentDirectory) =
|
|
case attachmentName of
|
|
Just attachmentName'
|
|
| Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
|
|
(Zlib.ungzip, Just directoryName')
|
|
| Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
|
|
(Lzma.decompress Nothing, Just directoryName')
|
|
_ -> (pure (), Nothing)
|
|
runConduitRes $ responseBodySource response
|
|
.| decompress
|
|
.| untar (withDecompressedFile toTarget)
|
|
pure $ Text.pack <$> attachmentDirectory
|
|
withDecompressedFile toTarget FileInfo{..}
|
|
| Char8.last filePath /= '/' =
|
|
sinkFile (toTarget </> Char8.unpack filePath)
|
|
| otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))
|