296 lines
11 KiB
Haskell
296 lines
11 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 qualified Data.List.NonEmpty as NonEmpty
|
|
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(..))
|
|
import qualified Text.URI as URI
|
|
import Network.HTTP.Req
|
|
( useHttpsURI
|
|
, HEAD(..)
|
|
, NoReqBody(..)
|
|
, req
|
|
, runReq
|
|
, defaultHttpConfig
|
|
, ignoreResponse
|
|
, responseStatusCode
|
|
, HttpConfig(..)
|
|
, GET(..)
|
|
, reqBr, MonadHttp
|
|
)
|
|
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(..))
|
|
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 :: Text -> SlackBuilderT URI
|
|
hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
|
|
>>= liftIO . URI.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
|
|
|
|
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)
|
|
|
|
cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (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 (remoteResultURI,) . snd
|
|
<$> download remoteResultURI (takeDirectory localPath)
|
|
else
|
|
let go = sourceFile localPath .| sinkHash
|
|
in cloneAndArchive repo tarballPath tagPrefix
|
|
>> uploadCommand 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.
|
|
uploadCommand :: FilePath -> Text -> SlackBuilderT ()
|
|
uploadCommand localPath remotePath' = do
|
|
remoteRoot <- SlackBuilderT $ asks remotePath
|
|
|
|
liftIO $ callProcess "scp"
|
|
[ localPath
|
|
, Text.unpack $ remoteRoot <> remotePath'
|
|
]
|
|
|
|
-- | 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.
|
|
--
|
|
-- 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' ->
|
|
(Lzma.decompress Nothing, 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
|
|
| Just (httpsURI, httpsOptions) <- useHttpsURI uri =
|
|
reqBr GET httpsURI NoReqBody httpsOptions bodyReader
|
|
| otherwise = throwM $ HttpsUrlExpected uri
|