d-tools: Migrate source downloads with git clone
This commit is contained in:
216
lib/SlackBuilder/Download.hs
Normal file
216
lib/SlackBuilder/Download.hs
Normal file
@ -0,0 +1,216 @@
|
||||
module SlackBuilder.Download
|
||||
( clone
|
||||
, cloneAndArchive
|
||||
, commit
|
||||
, download
|
||||
, downloadAndDeploy
|
||||
, hostedSources
|
||||
, remoteFileExists
|
||||
, updateSlackBuildVersion
|
||||
, uploadCommand
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
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)
|
||||
import System.FilePath ((</>), (<.>), takeBaseName, splitPath, joinPath)
|
||||
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 Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
|
||||
import Data.Void (Void)
|
||||
|
||||
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
|
||||
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 :: 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']
|
||||
|
||||
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)
|
||||
|
||||
clone :: Text -> Text -> Text -> SlackBuilderT (Maybe (Digest MD5))
|
||||
clone repo tarball tagPrefix = do
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
let tarballPath = Text.unpack tarball
|
||||
nameVersion = Text.pack $ takeBaseName tarballPath
|
||||
remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
|
||||
localPath = repository' </> tarballPath
|
||||
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
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user