213 lines
7.3 KiB
Haskell
213 lines
7.3 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
|
|
( clone
|
|
, cloneAndArchive
|
|
, commit
|
|
, download
|
|
, hostedSources
|
|
, remoteFileExists
|
|
, updateSlackBuildVersion
|
|
, uploadCommand
|
|
) where
|
|
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as ByteString
|
|
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.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 -> 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 :: 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
|