Support repository path in commits

app/Main.hs

@@ -7,23 +7,33 @@ import Data.Maybe (fromMaybe)
 import Options.Applicative (execParser)
 import SlackBuilder.CommandLine
 import SlackBuilder.Config
+import SlackBuilder.Trans
 import SlackBuilder.Updater
 import qualified Toml
 import qualified Data.Text as Text
+import Control.Monad.Trans.Reader (ReaderT(..))
+import SlackBuilder.Download
 
 main :: IO ()
 main = do
     programCommand <- execParser slackBuilderParser
     settings <- Toml.decodeFile settingsCodec "config/config.toml"
-    latestVersion <- case programCommand of
+    latestVersion <- flip runReaderT settings
-        PackagistCommand packagistArguments ->
+        $ runSlackBuilderT
-            latestPackagist packagistArguments
+        $ executeCommand programCommand
-        TextCommand textArguments -> latestText textArguments
-        GhCommand ghArguments@GhArguments{ transform } ->
-            latestGitHub settings ghArguments $ chooseTransformFunction transform
 
     Text.IO.putStrLn $ fromMaybe "" latestVersion
   where
+    executeCommand = \case
+        PackagistCommand packagistArguments ->
+            latestPackagist packagistArguments
+        TextCommand textArguments -> latestText textArguments
+        GhCommand ghArguments@GhArguments{ transform }
+            -> latestGitHub ghArguments $ chooseTransformFunction transform
+        SlackBuildCommand packagePath version ->
+            updateSlackBuildVersion packagePath version >> pure Nothing
+        CommitCommand packagePath version ->
+            commit packagePath version >> pure Nothing
     chooseTransformFunction (Just "php") = phpTransform
     chooseTransformFunction (Just "rdiff-backup") = Text.stripPrefix "v"
     chooseTransformFunction _ = stripPrefix "v"

app/SlackBuilder/CommandLine.hs

@@ -23,6 +23,9 @@ data SlackBuilderCommand
     = PackagistCommand PackagistArguments
     | TextCommand TextArguments
     | GhCommand GhArguments
+    | SlackBuildCommand Text Text
+    | CommitCommand Text Text
+    deriving (Eq, Show)
 
 data PackagistArguments = PackagistArguments
     { vendor :: Text
@@ -36,6 +39,7 @@ data GhArguments = GhArguments
     } deriving (Eq, Show)
 
 newtype TextArguments = TextArguments Text
+    deriving (Eq, Show)
 
 packagistArguments :: Parser PackagistArguments
 packagistArguments = PackagistArguments
@@ -59,3 +63,12 @@ slackBuilderCommand = subparser
     $ command "packagist" (info (PackagistCommand <$> packagistArguments) mempty)
     <> command "text" (info (TextCommand <$> textArguments) mempty)
     <> command "github" (info (GhCommand <$> ghArguments) mempty)
+    <> command "slackbuild" (info slackBuildCommand mempty)
+    <> command "commit" (info commitCommand mempty)
+  where
+    slackBuildCommand = SlackBuildCommand
+        <$> argument str (metavar "PATH")
+        <*> argument str (metavar "VERSION")
+    commitCommand = CommitCommand
+        <$> argument str (metavar "PATH")
+        <*> argument str (metavar "VERSION")

app/SlackBuilder/Config.hs

@@ -7,10 +7,14 @@ import Data.Text (Text)
 import Toml ((.=))
 import qualified Toml
 
-newtype Settings = Settings
+data Settings = Settings
-    { ghToken :: Text
+    { ghToken :: !Text
+    , repository :: !FilePath
+    , branch :: Text
     } deriving (Eq, Show)
 
 settingsCodec :: Toml.TomlCodec Settings
 settingsCodec = Settings
     <$> Toml.text "gh_token" .= ghToken
+    <*> Toml.string "repository" .= repository
+    <*> Toml.text "branch" .= branch

app/SlackBuilder/Download.hs

@@ -0,0 +1,56 @@
+module SlackBuilder.Download
+    ( commit
+    , updateSlackBuildVersion
+    ) where
+
+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 ((</>), (<.>))
+import System.Process (CreateProcess(..), StdStream(..), proc, readCreateProcessWithExitCode, callProcess)
+import System.Exit (ExitCode(..))
+import Control.Monad (unless)
+
+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
+    let message = Text.unpack
+            $ packagePath <> ": Updated for version " <> version
+
+    (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" ["-C", repository', "commit", "-S", "-m", message]
+  where
+    testCheckout repository' branch' nullHandle =
+        let createCheckoutProcess = (proc "git" ["-C", repository', "checkout", branch'])
+                { std_in = NoStream
+                , std_err = UseHandle nullHandle
+                }
+         in readCreateProcessWithExitCode createCheckoutProcess ""

app/SlackBuilder/Trans.hs

@@ -0,0 +1,29 @@
+module SlackBuilder.Trans
+    ( SlackBuilderT(..)
+    ) where
+
+import Control.Monad.Trans.Reader (ReaderT(..))
+import SlackBuilder.Config
+import Control.Monad.IO.Class (MonadIO(..))
+
+newtype SlackBuilderT a = SlackBuilderT
+    { runSlackBuilderT :: ReaderT Settings IO a
+    }
+
+instance Functor SlackBuilderT
+  where
+    fmap f (SlackBuilderT slackBuilderT) = SlackBuilderT $ f <$> slackBuilderT
+
+instance Applicative SlackBuilderT
+  where
+    pure = SlackBuilderT . pure
+    (SlackBuilderT f) <*> (SlackBuilderT x) = SlackBuilderT $ f <*> x
+
+instance Monad SlackBuilderT
+  where
+    return = pure
+    (SlackBuilderT x) >>= f = SlackBuilderT $ x >>= runSlackBuilderT . f
+
+instance MonadIO SlackBuilderT
+  where
+    liftIO = SlackBuilderT . liftIO

app/SlackBuilder/Updater.hs

@@ -29,8 +29,11 @@ import Network.HTTP.Req
     )
 import Text.URI (mkURI)
 import SlackBuilder.CommandLine
+import SlackBuilder.Trans
 import qualified Data.Aeson.KeyMap as KeyMap
 import GHC.Records (HasField(..))
+import Control.Monad.Trans.Reader (ReaderT(..), asks)
+import Control.Monad.IO.Class (MonadIO(..))
 
 newtype PackagistPackage = PackagistPackage
     { version :: Text
@@ -86,7 +89,7 @@ data GhQuery = GhQuery
 
 $(deriveJSON defaultOptions ''GhQuery)
 
-latestPackagist :: PackagistArguments -> IO (Maybe Text)
+latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text)
 latestPackagist PackagistArguments{..} = do
     packagistResponse <- runReq defaultHttpConfig $
         let uri = https "repo.packagist.org" /: "p2"
@@ -99,9 +102,9 @@ latestPackagist PackagistArguments{..} = do
     pure $ HashMap.lookup fullName packagistPackages
         >>= fmap (version . fst) . Vector.uncons
 
-latestText :: TextArguments -> IO (Maybe Text)
+latestText :: TextArguments -> SlackBuilderT (Maybe Text)
 latestText (TextArguments textArguments) = do
-    uri <- useHttpsURI <$> mkURI textArguments
+    uri <- liftIO $ useHttpsURI <$> mkURI textArguments
     packagistResponse <- traverse (runReq defaultHttpConfig) $ go . fst <$> uri
 
     pure $ Text.strip . Text.Encoding.decodeASCII . responseBody
@@ -109,8 +112,12 @@ latestText (TextArguments textArguments) = do
   where
     go uri = req GET uri NoReqBody bsResponse mempty
 
-latestGitHub :: Settings -> GhArguments -> (Text -> Maybe Text) -> IO (Maybe Text)
+latestGitHub
-latestGitHub Settings{..} GhArguments{..} versionTransform = do
+    :: GhArguments
+    -> (Text -> Maybe Text)
+    -> SlackBuilderT (Maybe Text)
+latestGitHub GhArguments{..} versionTransform = do
+    ghToken' <- SlackBuilderT $ asks ghToken
     ghResponse <- runReq defaultHttpConfig $
         let uri = https "api.github.com" /: "graphql"
             query = GhQuery
@@ -122,10 +129,13 @@ latestGitHub Settings{..} GhArguments{..} versionTransform = do
                 }
             authorizationHeader = header "authorization"
                 $ Text.Encoding.encodeUtf8
-                $ "Bearer " <> ghToken
+                $ "Bearer " <> ghToken'
          in req POST uri (ReqBodyJson query) jsonResponse
             $ authorizationHeader <> header "User-Agent" "SlackBuilder"
-    let ghNodes = nodes $ refs $ repository $ responseBody ghResponse
+    let ghNodes = nodes
+            $ refs
+            $ (getField @"repository" :: GhData -> GhRepository)
+            $ responseBody ghResponse
         refs' = Vector.reverse
             $ Vector.catMaybes
             $ versionTransform . getField @"name" <$> ghNodes

config/config.rb.example

@@ -3,6 +3,5 @@
 CONFIG = {
   remote_path: 'example.com:/srv/httpd/some/path',
   download_url: 'https://example.com/some/path',
-  branch: 'user/nick/updates',
   repository: '../slackbuilds'
 }.freeze

config/config.toml.example

@@ -1 +1,3 @@
 gh_token = ""
+repository = "./slackbuilds"
+branch = "user/nick/updates"

lib/download.rb

@@ -134,24 +134,9 @@ def write_info(package, downloads:)
 end
 
 def update_slackbuild_version(package_path, version)
-  raise TypeError, %(expected a version string, got "#{version}") unless version.is_a?(String)
+  sh './bin/slackbuilder', 'slackbuild', package_path, version
-
-  name = package_path.split('/').last
-  slackbuild_filename = "slackbuilds/#{package_path}/#{name}.SlackBuild"
-  slackbuild_contents = File.read(slackbuild_filename)
-    .gsub(/^VERSION=\${VERSION:-.+/, "VERSION=${VERSION:-#{version}}")
-
-  File.open(slackbuild_filename, 'w') { |file| file.puts slackbuild_contents }
 end
 
 def commit(package_path, version)
-  message = "#{package_path}: Updated for version #{version}"
+  sh './bin/slackbuilder', 'commit', package_path, version
-
-  unless system('git', '-C', 'slackbuilds', 'checkout', CONFIG[:branch],
-    err: '/dev/null')
-    sh 'git', '-C', 'slackbuilds', 'checkout', '-b', CONFIG[:branch], 'master'
-  end
-  sh 'git', '-C', 'slackbuilds', 'add', package_path
-  sh 'git', '-C', 'slackbuilds', 'commit', '-S', '-m', message
-  # sh 'git', '-C', 'slackbuilds', 'push', 'origin', CONFIG[:branch]
 end

lib/up2date.rb

@@ -22,20 +22,6 @@ module SlackBuilder
 
   # Reads the list fo tags from the GitHub API.
   class GitHub < Repository
-    GITHUB_QUERY = <<~GQL
-      query ($name: String!, $owner: String!) {
-        repository(name: $name, owner: $owner) {
-          refs(last: 10, refPrefix: "refs/tags/", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {
-            nodes {
-              id,
-              name
-            }
-          }
-        }
-      }
-    GQL
-    private_constant :GITHUB_QUERY
-
     def initialize(owner, name, version_transform = nil)
       super()
 

slackbuilder.cabal

@@ -24,10 +24,13 @@ executable slackbuilder
     other-modules:
         SlackBuilder.CommandLine
         SlackBuilder.Config
+        SlackBuilder.Download
+        SlackBuilder.Trans
         SlackBuilder.Updater
     default-extensions:
         DataKinds
         DuplicateRecordFields
+        LambdaCase
         NamedFieldPuns
         OverloadedStrings
         RecordWildCards
@@ -37,11 +40,14 @@ executable slackbuilder
         aeson ^>= 2.2.0,
         base ^>= 4.16.4.0,
         bytestring ^>= 0.11.0,
+        filepath ^>= 1.4.2,
         modern-uri ^>= 0.3.6,
         optparse-applicative ^>= 0.18.1,
+        process ^>= 1.6.17,
         req ^>= 3.13,
         text ^>= 2.0,
         tomland ^>= 1.3.3,
+        transformers ^>= 0.5.6,
         unordered-containers ^>= 0.2.19,
         vector ^>= 0.13.0
     hs-source-dirs: app