1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-26 02:54:50 +09:00

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.
This commit is contained in:
fr33domlover 2019-10-07 14:05:52 +00:00
parent c529722b5a
commit 6cb86ebbf1
10 changed files with 94 additions and 8 deletions

View file

@ -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

17
hook-darcs/main.hs Normal file
View file

@ -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!"

View file

@ -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)

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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 $

View file

@ -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.

View file

@ -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