d-tools: Migrate source downloads with git clone

1 files changed, 216 insertions, 0 deletions

diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs
new file mode 100644
index 0000000..011def7
--- /dev/null
+++ b/lib/SlackBuilder/Download.hs
@@ -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