Install darcs post-apply hooks in darcs repos, no-op hook for now

In Darcs, any command can have a post hook (and a pre hook), and the hook
command can be set using a command-line option to the darcs command that you
run. So, in the Vervis SSH server, if we add a --posthook option when running
`darcs apply` to apply remotely received patches, we get a chance to process
the patch data much like in the git post-receive hook.

The setup this patch creates is similar to the git one: It writes a
_darcs/prefs/defaults file to all Darcs repos, and that defaults file sets the
posthook line for `darcs apply`. The posthook line simply executes the actual
hook program written in Haskell.

The current hook program is a one-liner that prints a line to stdout, so every
time you `darcs push` you can tell the hook got executed. The next step is to
implement the actual hook logic, by reading patch data from the environment
variable in which Darcs puts it.

config/settings-default.yaml

@@ -80,6 +80,7 @@ max-actor-keys:     2
 repo-dir:           repos
 diff-context-lines: 5
 #post-receive-hook:  /home/joe/.local/bin/vervis-post-receive
+#post-apply-hook:    /home/joe/.local/bin/vervis-post-apply
 
 ###############################################################################
 # SSH server

hook-darcs/main.hs

@@ -0,0 +1,17 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+main :: IO ()
+main = putStrLn "Hello, I'm the posthook!"

src/Darcs/Local/Repository.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,19 +14,35 @@
  -}
 
 module Darcs.Local.Repository
-    ( createRepo
+    ( writeDefaultsFile
+    , createRepo
     , readPristineRoot
     )
 where
 
 import Darcs.Util.Hash
+import Data.Bits
+import Data.Text (Text)
 import System.Directory (createDirectory)
 import System.Exit (ExitCode (..))
 import System.FilePath ((</>))
 import System.IO (withBinaryFile, IOMode (ReadMode))
+import System.Posix.Files
 import System.Process (createProcess, proc, waitForProcess)
 
 import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+
+writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO ()
+writeDefaultsFile path cmd sharer repo = do
+    let file = path </> "_darcs" </> "prefs" </> "defaults"
+    TIO.writeFile file $ defaultsContent cmd sharer repo
+    setFileMode file $ ownerReadMode .|. ownerWriteMode
+    where
+    defaultsContent :: FilePath -> Text -> Text -> Text
+    defaultsContent hook sharer repo =
+        T.concat ["apply posthook ", T.pack hook, " ", sharer, " ", repo]
 
 {-
 initialRepoTree :: FileName -> DirTree B.ByteString
@@ -56,15 +72,21 @@ createRepo
     -- ^ Parent directory which already exists
     -> String
     -- ^ Name of new repo, i.e. new directory to create under the parent
+    -> FilePath
+    -- ^ Path of Vervis hook program
+    -> Text
+    -- ^ Repo sharer textual ID
+    -> Text
+    -- ^ Repo textual ID
     -> IO ()
-createRepo parent name = do
+createRepo parent name cmd sharer repo = do
     let path = parent </> name
     createDirectory path
     let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path]
     (_, _, _, ph) <- createProcess settings
     ec <- waitForProcess ph
     case ec of
-        ExitSuccess   -> return ()
+        ExitSuccess   -> writeDefaultsFile path cmd sharer repo
         ExitFailure n -> error $ "darcs init failed with exit code " ++ show n
 
 readPristineRoot :: FilePath -> IO (Maybe Int, Hash)

src/Vervis/Application.hs

@@ -74,6 +74,7 @@ import Control.Concurrent.Local
 import Web.Hashids.Local
 
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
+import Vervis.Darcs
 import Vervis.Federation
 import Vervis.Foundation
 import Vervis.Git
@@ -199,6 +200,7 @@ makeFoundation appSettings = do
                 fixRunningDeliveries
                 deleteUnusedURAs
                 writePostReceiveHooks
+                writePostApplyHooks
 
     writeHookConfig Config
         { configSecret     = hookSecretText appHookSecret

src/Vervis/Darcs.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -19,6 +19,7 @@ module Vervis.Darcs
     , readChangesView
     , lastChange
     , readPatch
+    , writePostApplyHooks
     )
 where
 
@@ -26,6 +27,7 @@ import Prelude hiding (lookup)
 
 import Control.Applicative ((<|>))
 import Control.Arrow (second)
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
 import Darcs.Util.Path
@@ -33,6 +35,7 @@ import Darcs.Util.Tree
 import Darcs.Util.Tree.Hashed
 import Data.Bool (bool)
 import Data.ByteString (ByteString)
+import Data.Foldable hiding (find)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
 import Data.Text (Text)
@@ -56,8 +59,12 @@ import qualified Data.Foldable as F (find)
 import qualified Data.List.NonEmpty as N
 import qualified Data.Text as T (unpack, takeWhile, stripEnd)
 import qualified Data.Vector as V (empty)
+import qualified Database.Esqueleto as E
+
 import qualified Development.Darcs.Internal.Patch.Parser as P
 
+import Yesod.MonadSite
+
 import Darcs.Local.Repository
 import Data.Either.Local (maybeRight)
 import Data.EventTime.Local
@@ -66,9 +73,14 @@ import Data.Text.UTF8.Local (decodeStrict)
 import Data.Time.Clock.Local ()
 
 import Vervis.Changes
-import Vervis.Foundation (Widget)
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Model.Repo
 import Vervis.Patch
+import Vervis.Path
 import Vervis.Readme
+import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Wiki (WikiView (..))
 
@@ -314,3 +326,14 @@ readPatch path hash = do
         <*  A.skip (== '>')
     mkedit (file, hunks) =
         EditTextFile (T.unpack $ decodeUtf8 file) V.empty hunks 0 0
+
+writePostApplyHooks :: WorkerDB ()
+writePostApplyHooks = do
+    repos <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do
+        E.on $ r E.^. RepoSharer E.==. s E.^. SharerId
+        E.where_ $ r E.^. RepoVcs E.==. E.val VCSDarcs
+        return (s E.^. SharerIdent, r E.^. RepoIdent)
+    hook <- asksSite $ appPostApplyHookFile . appSettings
+    for_ repos $ \ (E.Value shr, E.Value rp) -> do
+        path <- askRepoDir shr rp
+        liftIO $ writeDefaultsFile path hook (shr2text shr) (rp2text rp)

src/Vervis/Git.hs

@@ -79,6 +79,7 @@ import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Repo
 import Vervis.Patch
 import Vervis.Path
 import Vervis.Readme
@@ -334,6 +335,7 @@ writePostReceiveHooks :: WorkerDB ()
 writePostReceiveHooks = do
     repos <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do
         E.on $ r E.^. RepoSharer E.==. s E.^. SharerId
+        E.where_ $ r E.^. RepoVcs E.==. E.val VCSGit
         return (s E.^. SharerIdent, r E.^. RepoIdent)
     hook <- asksSite $ appPostReceiveHookFile . appSettings
     for_ repos $ \ (E.Value shr, E.Value rp) -> do

src/Vervis/Handler/Repo.hs

@@ -146,7 +146,15 @@ postReposR user = do
             let repoName =
                     unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
             case nrpVcs nrp of
-                VCSDarcs -> liftIO $ D.createRepo parent repoName
+                VCSDarcs -> do
+                    hook <- getsYesod $ appPostApplyHookFile . appSettings
+                    liftIO $
+                        D.createRepo
+                            parent
+                            repoName
+                            hook
+                            (shr2text user)
+                            (rp2text $ nrpIdent nrp)
                 VCSGit -> do
                     hook <- getsYesod $ appPostReceiveHookFile . appSettings
                     liftIO $

src/Vervis/Settings.hs

@@ -135,6 +135,8 @@ data AppSettings = AppSettings
     , appDiffContextLines       :: Int
       -- | Path of the Vervis post-receive hook executable
     , appPostReceiveHookFile    :: FilePath
+      -- | Path of the Vervis darcs posthook executable
+    , appPostApplyHookFile      :: FilePath
       -- | Port for the SSH server component to listen on
     , appSshPort                :: Int
       -- | Path to the server's SSH private key file
@@ -229,6 +231,7 @@ instance FromJSON AppSettings where
         appRepoDir                <- o .: "repo-dir"
         appDiffContextLines       <- o .: "diff-context-lines"
         appPostReceiveHookFile    <- o .:? "post-receive-hook" .!= detectedHookFile
+        appPostApplyHookFile      <- o .:? "post-apply-hook" .!= detectedDarcsHookFile
         appSshPort                <- o .: "ssh-port"
         appSshKeyFile             <- o .: "ssh-key-file"
         appRegister               <- o .: "registration"
@@ -257,6 +260,7 @@ instance FromJSON AppSettings where
         toSeconds = toTimeUnit
         ndt = fromIntegral . toSeconds . interval
         detectedHookFile = $localInstallRoot </> "bin" </> "vervis-post-receive"
+        detectedDarcsHookFile = $localInstallRoot </> "bin" </> "vervis-post-apply"
 
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.

vervis.cabal

@@ -403,7 +403,14 @@ executable vervis
 executable vervis-post-receive
   main-is:             main.hs
   build-depends:       base, vervis
-  hs-source-dirs:      hook
+  hs-source-dirs:      hook-git
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+executable vervis-post-apply
+  main-is:             main.hs
+  build-depends:       base, vervis
+  hs-source-dirs:      hook-darcs
   default-language:    Haskell2010
   ghc-options:         -Wall