From 396a536b3a6eed284c7fda88695178ae46ba9ee3 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 28 Oct 2023 21:24:21 +0200 Subject: d-tools: Migrate source downloads with git clone --- app/Main.hs | 13 ++- app/SlackBuilder/Download.hs | 216 ------------------------------------------- lib/SlackBuilder/Download.hs | 216 +++++++++++++++++++++++++++++++++++++++++++ slackbuilder.cabal | 10 +- 4 files changed, 233 insertions(+), 222 deletions(-) delete mode 100644 app/SlackBuilder/Download.hs create mode 100644 lib/SlackBuilder/Download.hs diff --git a/app/Main.hs b/app/Main.hs index ee8b2c8..ffd9294 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -23,6 +23,7 @@ import SlackBuilder.Download import SlackBuilder.Package (Package(..)) import qualified SlackBuilder.Package as Package import Text.URI (URI(..), mkURI) +import Text.URI.QQ (uri) import Crypto.Hash (Digest, MD5) import Data.Foldable (for_, find) import qualified Text.URI as URI @@ -231,11 +232,21 @@ autoUpdatable = , name = "d-tools" , downloaders = let dubArguments = GhArguments{ owner = "dlang", name = "dub", transform = Nothing} + dscannerArguments = GhArguments{ owner = "dlang-community", name = "D-Scanner", transform = Nothing } + dcdArguments = GhArguments{ owner = "dlang-community", name = "DCD", transform = Nothing } latestDub = latestGitHub dubArguments pure + latestDscanner = latestGitHub dscannerArguments pure + latestDcd = latestGitHub dcdArguments pure dubTemplate = Package.DownloadTemplate $ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v" :| [Package.VersionPlaceholder] - in [Package.Updater latestDub $ downloadWithTemplate dubTemplate] + dscannerURI = [uri|https://github.com/dlang-community/D-Scanner.git|] + dcdURI = [uri|https://github.com/dlang-community/DCD.git|] + in + [ Package.Updater latestDub $ downloadWithTemplate dubTemplate + , Package.Updater latestDscanner $ cloneFromGit dscannerURI "v" + , Package.Updater latestDcd $ cloneFromGit dcdURI "v" + ] } ] diff --git a/app/SlackBuilder/Download.hs b/app/SlackBuilder/Download.hs deleted file mode 100644 index 011def7..0000000 --- a/app/SlackBuilder/Download.hs +++ /dev/null @@ -1,216 +0,0 @@ -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 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 diff --git a/slackbuilder.cabal b/slackbuilder.cabal index c589d0b..0b5fef8 100644 --- a/slackbuilder.cabal +++ b/slackbuilder.cabal @@ -27,6 +27,7 @@ common dependencies memory ^>= 0.18, parser-combinators ^>= 1.3, process ^>= 1.6.18, + req ^>= 3.13, text ^>= 2.0, tomland ^>= 1.3.3, transformers ^>= 0.5.6, @@ -49,12 +50,15 @@ library import: dependencies exposed-modules: SlackBuilder.Config + SlackBuilder.Download SlackBuilder.Info SlackBuilder.Package SlackBuilder.Trans hs-source-dirs: lib build-depends: - exceptions >= 0.10 + conduit ^>= 1.3.5, + exceptions >= 0.10, + http-client ^>= 0.7 ghc-options: -Wall @@ -64,15 +68,11 @@ executable slackbuilder other-modules: SlackBuilder.CommandLine - SlackBuilder.Download SlackBuilder.Updater build-depends: aeson ^>= 2.2.0, ansi-terminal ^>= 1.0, - conduit ^>= 1.3.5, - http-client ^>= 0.7, optparse-applicative ^>= 0.18.1, - req ^>= 3.13, slackbuilder, unordered-containers ^>= 0.2.19, vector ^>= 0.13.0 -- cgit v1.2.3