slackbuilder/app/SlackBuilder/Download.hs

217 lines
7.3 KiB
Haskell
Raw Normal View History

2023-08-15 10:33:19 +02:00
module SlackBuilder.Download
2023-08-25 10:30:24 +02:00
( clone
, cloneAndArchive
, commit
2023-08-21 13:38:20 +02:00
, download
2023-08-28 21:05:47 +02:00
, downloadAndDeploy
, hostedSources
, remoteFileExists
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
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.IO (IOMode(..), withFile)
2023-08-25 10:30:24 +02:00
import System.FilePath ((</>), (<.>), takeBaseName, splitPath, joinPath)
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(..), mkURI)
import Network.HTTP.Req
( useHttpsURI
, HEAD(..)
, NoReqBody(..)
, req
, runReq
, defaultHttpConfig
, ignoreResponse
2023-08-21 13:38:20 +02:00
, responseStatusCode
, HttpConfig(..)
, GET(..)
, reqBr
)
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 Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
2023-08-15 10:33:19 +02:00
updateSlackBuildVersion :: Text -> Text -> SlackBuilderT ()
updateSlackBuildVersion packagePath version = 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 (contentsHead, contentsTail) = Text.dropWhile (/= '\n')
<$> Text.breakOn "VERSION=${VERSION:-" slackbuildContents
liftIO $ Text.IO.writeFile slackbuildFilename
$ contentsHead <> "VERSION=${VERSION:-" <> version <> "}" <> contentsTail
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 . 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 :: Text -> Text -> SlackBuilderT ()
uploadCommand localPath remotePath' = do
remoteRoot <- SlackBuilderT $ asks remotePath
repository' <- SlackBuilderT $ asks repository
liftIO $ callProcess "scp"
[ repository' </> Text.unpack localPath
, Text.unpack $ remoteRoot <> remotePath'
]
cloneAndArchive :: Text -> Text -> FilePath -> Text -> SlackBuilderT ()
cloneAndArchive repo nameVersion tarball tagPrefix = do
let (_, version) = Text.breakOnEnd "-" nameVersion
nameVersion' = Text.unpack nameVersion
repository' <- SlackBuilderT $ asks repository
liftIO $ callProcess "rm" ["-rf", nameVersion']
liftIO $ callProcess "git" ["clone", Text.unpack repo, nameVersion']
liftIO $ callProcess "git"
[ "-C"
, nameVersion'
, "checkout"
, Text.unpack $ tagPrefix <> version
]
liftIO $ callProcess "git"
[ "-C"
, nameVersion'
, "submodule"
, "update"
, "--init"
, "--recursive"
]
liftIO $ callProcess "tar"
[ "Jcvf"
, repository' </> tarball
, nameVersion'
]
liftIO $ callProcess "rm" ["-rf", nameVersion']
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)
2023-08-25 10:30:24 +02:00
download :: URI -> FilePath -> SlackBuilderT (Maybe (Digest MD5))
download uri target = traverse (runReq defaultHttpConfig . go . fst)
$ useHttpsURI uri
2023-08-21 13:38:20 +02:00
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)
2023-08-25 10:30:24 +02:00
clone :: Text -> Text -> Text -> SlackBuilderT (Maybe (Digest MD5))
clone repo tarball tagPrefix = do
2023-08-28 21:05:47 +02:00
repository' <- SlackBuilderT $ asks repository
2023-08-25 10:30:24 +02:00
let tarballPath = Text.unpack tarball
nameVersion = Text.pack $ takeBaseName tarballPath
remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
2023-08-28 21:05:47 +02:00
localPath = repository' </> tarballPath
2023-08-25 10:30:24 +02:00
remoteFileExists' <- remoteFileExists remotePath
if remoteFileExists'
then
hostedSources remotePath >>= flip download localPath
else
let go = sourceFile localPath .| sinkHash
in cloneAndArchive repo nameVersion tarballPath tagPrefix
>> uploadCommand tarball remotePath
>> liftIO (runConduitRes go) <&> Just
2023-08-28 21:05:47 +02:00
downloadAndDeploy :: Text -> Text -> SlackBuilderT (Maybe (Digest MD5))
downloadAndDeploy uri tarball = do
repository' <- SlackBuilderT $ asks repository
let tarballPath = Text.unpack tarball
remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
localPath = repository' </> tarballPath
remoteFileExists' <- remoteFileExists remotePath
if remoteFileExists'
then
hostedSources remotePath >>= flip download localPath
else do
checksum <- liftIO (mkURI uri) >>= flip download localPath
uploadCommand tarball remotePath
pure checksum