Support repository path in commits

6 files changed, 137 insertions, 15 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 6901fa6..a90d19a 100644
--- a/app/Main.hs
+++ b/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
-        PackagistCommand packagistArguments ->
-            latestPackagist packagistArguments
-        TextCommand textArguments -> latestText textArguments
-        GhCommand ghArguments@GhArguments{ transform } ->
-            latestGitHub settings ghArguments $ chooseTransformFunction transform
+    latestVersion <- flip runReaderT settings
+        $ runSlackBuilderT
+        $ executeCommand programCommand
 
     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"
diff --git a/app/SlackBuilder/CommandLine.hs b/app/SlackBuilder/CommandLine.hs
index 1313abb..6b915f2 100644
--- a/app/SlackBuilder/CommandLine.hs
+++ b/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")
diff --git a/app/SlackBuilder/Config.hs b/app/SlackBuilder/Config.hs
index be91ae0..6e093a7 100644
--- a/app/SlackBuilder/Config.hs
+++ b/app/SlackBuilder/Config.hs
@@ -7,10 +7,14 @@ import Data.Text (Text)
 import Toml ((.=))
 import qualified Toml
 
-newtype Settings = Settings
-    { ghToken :: Text
+data Settings = Settings
+    { 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
diff --git a/app/SlackBuilder/Download.hs b/app/SlackBuilder/Download.hs
new file mode 100644
index 0000000..2b4f5dd
--- /dev/null
+++ b/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 ""
diff --git a/app/SlackBuilder/Trans.hs b/app/SlackBuilder/Trans.hs
new file mode 100644
index 0000000..d678a19
--- /dev/null
+++ b/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
diff --git a/app/SlackBuilder/Updater.hs b/app/SlackBuilder/Updater.hs
index 0e927e2..ec96018 100644
--- a/app/SlackBuilder/Updater.hs
+++ b/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 Settings{..} GhArguments{..} versionTransform = do
+latestGitHub
+    :: 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