diff --git a/config/settings-default.yaml b/config/settings-default.yaml index ace2023..0d76039 100644 --- a/config/settings-default.yaml +++ b/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 diff --git a/hook-darcs/main.hs b/hook-darcs/main.hs new file mode 100644 index 0000000..1d1de3f --- /dev/null +++ b/hook-darcs/main.hs @@ -0,0 +1,17 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +main :: IO () +main = putStrLn "Hello, I'm the posthook!" diff --git a/hook/main.hs b/hook-git/main.hs similarity index 100% rename from hook/main.hs rename to hook-git/main.hs diff --git a/src/Darcs/Local/Repository.hs b/src/Darcs/Local/Repository.hs index fd0be2d..3f91859 100644 --- a/src/Darcs/Local/Repository.hs +++ b/src/Darcs/Local/Repository.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ 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) diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 6ab9853..25e260a 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 3347b28..4ac47b3 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 467e274..c3930f7 100644 --- a/src/Vervis/Git.hs +++ b/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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 6642299..a9b16fc 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 $ diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index eefe5db..bfec872 100644 --- a/src/Vervis/Settings.hs +++ b/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. diff --git a/vervis.cabal b/vervis.cabal index e15326d..d5dddfa 100644 --- a/vervis.cabal +++ b/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