slackbuilder/lib/SlackBuilder/Download.hs

296 lines
11 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/. -}
2023-08-15 10:33:19 +02:00
module SlackBuilder.Download
( cloneAndUpload
, extractRemote
, commit
2023-08-21 13:38:20 +02:00
, download
, hostedSources
, remoteFileExists
2024-01-24 14:34:58 +01:00
, responseBodySource
, sinkHash
2023-08-15 10:33:19 +02:00
, updateSlackBuildVersion
2023-09-03 10:26:43 +02:00
, uploadCommand
2023-08-15 10:33:19 +02:00
) where
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
import qualified Data.List.NonEmpty as NonEmpty
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)
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)
import Text.URI (URI(..))
import qualified Text.URI as URI
import Network.HTTP.Req
( useHttpsURI
, HEAD(..)
, NoReqBody(..)
, req
, runReq
, defaultHttpConfig
, ignoreResponse
2023-08-21 13:38:20 +02:00
, responseStatusCode
, HttpConfig(..)
, GET(..)
, reqBr, MonadHttp
)
import Data.Functor ((<&>))
2023-08-21 13:38:20 +02:00
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
( ConduitT
, yield
, runConduitRes
, sinkFile
, (.|)
, ZipSink(..)
, await
2023-08-25 10:30:24 +02:00
, sourceFile
2023-08-21 13:38:20 +02:00
)
import Data.Conduit.Tar (untar, FileInfo(..))
2023-08-21 13:38:20 +02:00
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
import qualified Data.Conduit.Lzma as Lzma
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 ""
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]
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
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
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
>> uploadCommand 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.
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)
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' ->
(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