Mechanism for reporting git pushes to Vervis via post-receive hooks

Here's how it works:

- When Vervis starts, it writes a config file and it writes post-receive hooks
  into all the repos it manages
- When a git push is accepted, git runs the post-receive hook, which is a
  trivial shell script that executes the actual Haskell program implementing
  the hook logic
- The Haskell hook program generates a Push JSON object and HTTP POSTs it to
  Vervis running on localhost
- Vervis currently responds with an error, the next step is to implement the
  actual publishing of ForgeFed Push activities

config/routes

@@ -22,6 +22,12 @@
 
 /highlight/#Text/style.css                   HighlightStyleR   GET
 
+-- ----------------------------------------------------------------------------
+-- Internal
+-- ----------------------------------------------------------------------------
+
+/post-receive                                PostReceiveR      POST
+
 -- ----------------------------------------------------------------------------
 -- Federation
 -- ----------------------------------------------------------------------------

config/settings-default.yaml

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

hook/main.hs

@@ -0,0 +1,19 @@
+{- 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/>.
+ -}
+
+import Vervis.Hook
+
+main :: IO ()
+main = postReceive

src/Data/DList/Local.hs

@@ -0,0 +1,27 @@
+{- 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/>.
+ -}
+
+module Data.DList.Local
+    (
+    )
+where
+
+import Data.Graph.Inductive.Query.Topsort
+
+import qualified Data.DList as D
+
+instance ResultList D.DList where
+    emptyList = D.empty
+    appendItem = flip D.snoc

src/Data/Git/Local.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.
  -
@@ -15,7 +15,8 @@
 
 module Data.Git.Local
     ( -- * Initialize repo
-      createRepo
+      writeHookFile
+    , createRepo
       -- * View repo content
     , EntObjType (..)
     , TreeRows
@@ -27,8 +28,8 @@ module Data.Git.Local
     )
 where
 
+import Control.Exception
 import Control.Monad (when)
-import Data.Byteable (toBytes)
 import Data.Git
 import Data.Git.Harder
 import Data.Git.Ref (SHA1)
@@ -38,11 +39,13 @@ import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import System.Directory.Tree
+import System.FilePath
+import System.Posix.Files
 
-import qualified Data.ByteString as B (ByteString, writeFile)
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.Set as S (mapMonotonic)
-import qualified Data.Text as T (pack)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 
 import Data.EventTime.Local
 import Data.Hourglass.Local ()
@@ -51,9 +54,19 @@ instance SpecToEventTime GitTime where
     specToEventTime = specToEventTime . gitTimeUTC
     specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
 
-initialRepoTree :: FileName -> DirTree B.ByteString
+hookContent :: FilePath -> Text -> Text -> Text
-initialRepoTree repo =
+hookContent hook sharer repo =
-    Dir repo
+    T.concat ["#!/bin/sh\nexec ", T.pack hook, " ", sharer, " ", repo]
+
+writeHookFile :: FilePath -> FilePath -> Text -> Text -> IO ()
+writeHookFile path cmd sharer repo = do
+    let file = path </> "hooks" </> "post-receive"
+    TIO.writeFile file $ hookContent cmd sharer repo
+    setFileMode file ownerModes
+
+initialRepoTree :: FilePath -> Text -> Text -> FileName -> DirTree Text
+initialRepoTree hook sharer repo dir =
+    Dir dir
         [ Dir "branches" []
         , File "config"
             "[core]\n\
@@ -63,7 +76,9 @@ initialRepoTree repo =
         , File "description"
             "Unnamed repository; edit this file to name the repository."
         , File "HEAD" "ref: refs/heads/master"
-        , Dir "hooks" []
+        , Dir "hooks"
+            [ File "post-receive" $ hookContent hook sharer repo
+            ]
         , Dir "info"
             [ File "exclude" ""
             ]
@@ -87,12 +102,20 @@ 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 path name = do
+createRepo path name cmd sharer repo = do
-    let tree = path :/ initialRepoTree name
+    let tree = path :/ initialRepoTree cmd sharer repo name
-    result <- writeDirectoryWith B.writeFile tree
+    result <- writeDirectoryWith TIO.writeFile tree
     let errs = failures $ dirTree result
-    when (not . null $ errs) $ error $ show errs
+    when (not . null $ errs) $
+        throwIO $ userError $ show errs
+    setFileMode (path </> name </> "hooks" </> "post-receive") ownerModes
 
 data EntObjType = EntObjBlob | EntObjTree
 

src/Data/List/NonEmpty/Local.hs

@@ -19,9 +19,11 @@ module Data.List.NonEmpty.Local
     , groupWithExtractBy1
     , groupAllExtract
     , unionGroupsOrdWith
+    , nonEmptyE
     )
 where
 
+import Control.Monad.Trans.Except
 import Data.Function
 import Data.List.NonEmpty (NonEmpty (..))
 
@@ -84,3 +86,9 @@ unionGroupsOrdWith groupOrd itemOrd = go
                 let cs = unionOrdByNE (compare `on` itemOrd) as bs
                 in  (i, cs) : go zs ws
             GT -> (j, bs) : go xs ws
+
+nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
+nonEmptyE l e =
+    case NE.nonEmpty l of
+        Nothing -> throwE e
+        Just ne -> return ne

src/Vervis/API.hs

@@ -234,12 +234,6 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
     lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
     return lmid
     where
-    nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
-    nonEmptyE l e =
-        case nonEmpty l of
-            Nothing -> throwE e
-            Just ne -> return ne
-
     parseRecipsContextParent
         :: FedURI
         -> Maybe FedURI

src/Vervis/Application.hs

@@ -76,6 +76,8 @@ import Web.Hashids.Local
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
 import Vervis.Federation
 import Vervis.Foundation
+import Vervis.Git
+import Vervis.Hook
 import Vervis.KeyFile (isInitialSetup)
 import Vervis.RemoteActorStore
 
@@ -138,6 +140,8 @@ makeFoundation appSettings = do
 
     appInstanceMutex <- newInstanceMutex
 
+    appHookSecret <- generateKey
+
     appActorFetchShare <- newResultShare actorFetchShareAction
 
     appActivities <-
@@ -193,6 +197,13 @@ makeFoundation appSettings = do
                 $logInfo "DB migration success"
                 fixRunningDeliveries
                 deleteUnusedURAs
+                writePostReceiveHooks
+
+    writeHookConfig Config
+        { configSecret     = hookSecretText appHookSecret
+        , configPort       = fromIntegral $ appPort appSettings
+        , configMaxCommits = 20
+        }
 
     -- Return the foundation
     return app

src/Vervis/Foundation.hs

@@ -93,6 +93,7 @@ import Yesod.Paginate.Local
 import Vervis.Access
 import Vervis.ActorKey
 import Vervis.FedURI
+import Vervis.Hook
 import Vervis.Model
 import Vervis.Model.Group
 import Vervis.Model.Ident
@@ -125,6 +126,7 @@ data App = App
     , appInstanceMutex :: InstanceMutex
     , appCapSignKey   :: AccessTokenSecretKey
     , appHashidsContext :: HashidsContext
+    , appHookSecret      :: HookSecret
     , appActorFetchShare :: ActorFetchShare App
 
     , appActivities  :: Maybe (Int, TVar (Vector ActivityReport))
@@ -202,6 +204,7 @@ instance Yesod App where
                 handler
                 (getCurrentRoute >>= \ mr -> case mr of
                     Nothing                      -> return False
+                    Just PostReceiveR            -> return False
                     Just (SharerInboxR _)        -> return False
                     Just (ProjectInboxR _ _)     -> return False
                     Just (GitUploadRequestR _ _) -> return False
@@ -211,18 +214,18 @@ instance Yesod App where
                 defaultCsrfParamName
           )
         . ( \ handler -> do
-                {-
+                host <- getsYesod $ renderAuthority . siteInstanceHost
-                if developmentMode
+                port <- getsYesod $ appPort . appSettings
-                    then handler
+                mroute <- getCurrentRoute
-                    else do
+                let localhost = "localhost:" <> T.pack (show port)
-                -}
+                    expectedHost =
-                        host <-
+                        case mroute of
-                            getsYesod $
+                            Just PostReceiveR -> localhost
-                                renderAuthority . appInstanceHost . appSettings
+                            _ -> host
-                        bs <- lookupHeaders hHost
+                bs <- lookupHeaders hHost
-                        case bs of
+                case bs of
-                            [b] | b == encodeUtf8 host -> handler
+                    [b] | b == encodeUtf8 expectedHost -> handler
-                            _ -> invalidArgs [hostMismatch host bs]
+                    _ -> invalidArgs [hostMismatch expectedHost bs]
           )
         . defaultYesodMiddleware
         where
@@ -942,3 +945,5 @@ instance YesodBreadcrumbs App where
                                             )
 
         WikiPageR shr prj _page          -> ("Wiki", Just $ ProjectR shr prj)
+
+        _                                -> ("PAGE TITLE HERE", Nothing)

src/Vervis/Git.hs

@@ -19,16 +19,18 @@ module Vervis.Git
     , listRefs
     , readPatch
     , lastCommitTime
+    , writePostReceiveHooks
     )
 where
 
 import Control.Arrow ((***))
 import Control.Monad (join)
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except
 import Patience (diff, Item (..))
 import Data.Byteable (toBytes)
-import Data.Foldable (foldlM, find)
+import Data.Foldable
 import Data.Git.Diff
 import Data.Git.Graph
 import Data.Git.Harder
@@ -63,15 +65,24 @@ import qualified Data.Text as T (pack, unpack, break, strip)
 import qualified Data.Text.Encoding as TE (decodeUtf8With)
 import qualified Data.Text.Encoding.Error as TE (lenientDecode)
 import qualified Data.Vector as V (fromList)
+import qualified Database.Esqueleto as E
+
+import Yesod.MonadSite
 
 import Data.ByteString.Char8.Local (takeLine)
+import Data.DList.Local
 import Data.EventTime.Local
 import Data.Git.Local
 import Data.List.Local
+
 import Vervis.Changes
-import Vervis.Foundation (Widget)
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
 import Vervis.Patch
+import Vervis.Path
 import Vervis.Readme
+import Vervis.Settings
 import Vervis.SourceTree
 
 matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
@@ -147,10 +158,6 @@ readSourceView path ref dir = do
     let toTexts = S.mapMonotonic $ T.pack . refNameRaw
     return (toTexts bs, toTexts ts, renderSources dir <$> msv)
 
-instance ResultList D.DList where
-    emptyList = D.empty
-    appendItem = flip D.snoc
-
 readChangesView
     :: FilePath
     -- ^ Repository path
@@ -210,7 +217,7 @@ patch edits c = Patch
         in  (T.strip l, T.strip r)
     (title, desc) = split $ decodeUtf8 $ commitMessage c
 
-    makeAuthor (Person name email time) =
+    makeAuthor (G.Person name email time) =
         ( Author
             { authorName  = decodeUtf8 name
             , authorEmail =
@@ -322,3 +329,13 @@ lastCommitTime repo =
     utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
     utc0 = UTCTime (ModifiedJulianDay 0) 0
     foldlM' i l f = foldlM f i l
+
+writePostReceiveHooks :: WorkerDB ()
+writePostReceiveHooks = do
+    repos <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do
+        E.on $ r E.^. RepoSharer E.==. s E.^. SharerId
+        return (s E.^. SharerIdent, r E.^. RepoIdent)
+    hook <- asksSite $ appPostReceiveHookFile . appSettings
+    for_ repos $ \ (E.Value shr, E.Value rp) -> do
+        path <- askRepoDir shr rp
+        liftIO $ writeHookFile path hook (shr2text shr) (rp2text rp)

src/Vervis/Handler/Repo.hs

@@ -36,6 +36,7 @@ module Vervis.Handler.Repo
     , getDarcsDownloadR
 
     , getHighlightStyleR
+    , postPostReceiveR
     )
 where
 
@@ -120,13 +121,20 @@ postReposR user = do
     case result of
         FormSuccess nrp -> do
             parent <- askSharerDir user
-            liftIO $ do
+            liftIO $ createDirectoryIfMissing True parent
-                createDirectoryIfMissing True parent
+            let repoName =
-                let repoName =
+                    unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
-                        unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
+            case nrpVcs nrp of
-                case nrpVcs nrp of
+                VCSDarcs -> liftIO $ D.createRepo parent repoName
-                    VCSDarcs -> D.createRepo parent repoName
+                VCSGit -> do
-                    VCSGit   -> G.createRepo parent repoName
+                    hook <- getsYesod $ appPostReceiveHookFile . appSettings
+                    liftIO $
+                        G.createRepo
+                            parent
+                            repoName
+                            hook
+                            (shr2text user)
+                            (rp2text $ nrpIdent nrp)
             pid <- requireAuthId
             runDB $ do
                 let repo = Repo
@@ -375,3 +383,6 @@ getHighlightStyleR styleName =
         Nothing -> notFound
         Just style ->
             return $ TypedContent typeCss $ toContent $ styleToCss style
+
+postPostReceiveR :: Handler ()
+postPostReceiveR = error "TODO post-receive handler not implemented yet"

src/Vervis/Handler/Repo/Darcs.hs

@@ -57,8 +57,6 @@ import Data.ByteString.Char8.Local (takeLine)
 import Data.Paginate.Local
 import Text.FilePath.Local (breakExt)
 
-import qualified Darcs.Local.Repository as D (createRepo)
-
 import Vervis.ActivityPub
 import Vervis.ChangeFeed (changeFeed)
 import Vervis.Changes

src/Vervis/Handler/Repo/Git.hs

@@ -92,7 +92,6 @@ import Vervis.Widget.Repo
 import Vervis.Widget.Sharer
 
 import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Data.Git.Local as G (createRepo)
 import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs, readPatch)
 
 getGitRepoSource :: Repo -> ShrIdent -> RpIdent -> Text -> [Text] -> Handler Html

src/Vervis/Hook.hs

@@ -0,0 +1,286 @@
+{- 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/>.
+ -}
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Vervis.Hook
+    ( HookSecret ()
+    , hookSecretText
+    , Config (..)
+    , Author (..)
+    , Commit (..)
+    , Push (..)
+    , writeHookConfig
+    , postReceive
+    )
+where
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Crypto.Random
+import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Git hiding (Commit)
+import Data.Git.Ref
+import Data.Git.Types hiding (Commit)
+import Data.Git.Graph
+import Data.Git.Harder
+import Data.Graph.Inductive.Graph -- (noNodes)
+import Data.Graph.Inductive.Query.Topsort
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Data.Word
+import GHC.Generics
+import Network.HTTP.Client
+import System.Directory
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO
+import Text.Email.Aeson.Instances ()
+import Text.Email.Validate
+import Time.Types
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.DList as D
+import qualified Data.Git as G
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.IO as TIO
+
+import Data.KeyFile
+import Network.FedURI
+
+import Data.DList.Local
+import Data.List.NonEmpty.Local
+
+data HookSecret = HookSecret ByteString
+
+instance KeyFile HookSecret where
+    generateKey = HookSecret <$> getRandomBytes 32
+    parseKey b =
+        if B.length b == 32
+            then return $ HookSecret b
+            else error "HookSecret invalid length"
+    renderKey (HookSecret b) = b
+
+hookSecretText :: HookSecret -> Text
+hookSecretText (HookSecret b) = TE.decodeUtf8 $ B16.encode b
+
+data Config = Config
+    { configSecret     :: Text
+    , configPort       :: Word16
+    , configMaxCommits :: Int
+    }
+    deriving Generic
+
+instance FromJSON Config
+
+instance ToJSON Config
+
+data Author = Author
+    { authorName  :: Text
+    , authorEmail :: EmailAddress
+    }
+    deriving Generic
+
+instance FromJSON Author
+
+instance ToJSON Author
+
+data Commit = Commit
+    { commitWritten     :: (Author, UTCTime)
+    , commitCommitted   :: Maybe (Author, UTCTime)
+    , commitHash        :: Text
+    , commitTitle       :: Text
+    , commitDescription :: Text
+    }
+    deriving Generic
+
+instance FromJSON Commit
+
+instance ToJSON Commit
+
+data Push = Push
+    { pushSecret :: Text
+    , pushSharer :: Text
+    , pushRepo   :: Text
+    , pushBranch :: Maybe Text
+    , pushInit   :: NonEmpty Commit
+    , pushLast   :: Maybe (Int, NonEmpty Commit)
+    }
+    deriving Generic
+
+instance FromJSON Push
+
+instance ToJSON Push
+
+getVervisCachePath :: IO FilePath
+getVervisCachePath = getXdgDirectory XdgCache "vervis"
+
+hookConfigFileName :: String
+hookConfigFileName = "hook-config.json"
+
+writeHookConfig :: Config -> IO ()
+writeHookConfig config = do
+    cachePath <- getVervisCachePath
+    createDirectoryIfMissing True cachePath
+    encodeFile (cachePath </> hookConfigFileName) config
+
+reportNewCommits :: Config -> Text -> Text -> IO ()
+reportNewCommits config sharer repo = do
+    manager <- newManager defaultManagerSettings
+    withRepo "." $ loop manager
+    where
+    loop manager git = do
+        eof <- isEOF
+        unless eof $ do
+            result <- runExceptT $ do
+                line <- liftIO TIO.getLine
+                (old, new, refname) <-
+                    case T.words line of
+                        [o, n, r] -> return (o, n, r)
+                        _ -> throwE $ "Weird line: " <> line
+                moldRef <- parseRef old
+                newRef <- do
+                    mr <- parseRef new
+                    case mr of
+                        Nothing -> throwE $ "Ref deletion: " <> new
+                        Just r -> return r
+                branch <-
+                    case T.stripPrefix "refs/heads/" refname of
+                        Just t | not (T.null t) -> return t
+                        _ -> throwE $ "Unexpected refname: " <> refname
+                graph <- liftIO $ loadCommitGraphPT git [ObjId newRef]
+                nodes <-
+                    case topsortUnmixOrder graph (NodeStack [noNodes graph]) of
+                        Nothing -> throwE "Commit graph contains a cycle"
+                        Just ns -> return ns
+                historyAll <-
+                    case nonEmpty $ D.toList $ nodeLabel graph <$> nodes of
+                        Nothing -> throwE "Empty commit graph"
+                        Just h -> return h
+                historyNew <-
+                    case moldRef of
+                        Nothing -> return historyAll
+                        Just oldRef -> do
+                            let (before, after) =
+                                    NE.break
+                                        ((== ObjId oldRef) . fst)
+                                        historyAll
+                            when (null after) $
+                                throwE "oldRef not found"
+                            nonEmptyE before "No new commits"
+                let commits = NE.map (uncurry makeCommit) historyNew
+                    maxCommits = configMaxCommits config
+                (early, late) <-
+                    if length commits <= maxCommits
+                        then return (commits, Nothing)
+                        else do
+                            let half = maxCommits `div` 2
+                                middle = length commits - 2 * half
+                                (e, r) = NE.splitAt half commits
+                                l = drop middle r
+                            eNE <- nonEmptyE e "early is empty"
+                            lNE <- nonEmptyE l "late is empty"
+                            return (eNE, Just (middle, lNE))
+                let push = Push
+                        { pushSecret = configSecret config
+                        , pushSharer = sharer
+                        , pushRepo   = repo
+                        , pushBranch = Just branch
+                        , pushInit   = early
+                        , pushLast   = late
+                        }
+                    uri :: ObjURI Dev
+                    uri =
+                        ObjURI
+                            (Authority "localhost" (Just $ configPort config))
+                            (LocalURI "/post-receive")
+                req <- requestFromURI $ uriFromObjURI uri
+                let req' =
+                        setRequestCheckStatus $
+                        req { method      = "POST"
+                            , requestBody = RequestBodyLBS $ encode push
+                            }
+                ExceptT $
+                    first adaptErr <$> try (httpNoBody req' manager)
+            case result of
+                Left e -> TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
+                Right _resp -> return ()
+            loop manager git
+        where
+        adaptErr :: HttpException -> Text
+        adaptErr = T.pack . displayException
+        parseRef t =
+            if t == nullRef
+                then return Nothing
+                else
+                    let b = TE.encodeUtf8 t
+                    in  if isHex b
+                            then return $ Just $ fromHex b
+                            else throwE $ "Invalid ref: " <> t
+            where
+            nullRef = T.replicate 40 "0"
+        makeCommit (ObjId ref) c = Commit
+            { commitWritten     = makeAuthor $ commitAuthor c
+            , commitCommitted   =
+                if commitAuthor c == commitCommitter c
+                    then Nothing
+                    else Just $ makeAuthor $ commitCommitter c
+            , commitHash        = T.pack $ toHexString ref
+            , commitTitle       = title
+            , commitDescription = desc
+            }
+            where
+            split t =
+                let (l, r) = T.break (\ c -> c == '\n' || c == '\r') t
+                in  (T.strip l, T.strip r)
+            (title, desc) = split $ TE.decodeUtf8 $ commitMessage c
+
+            makeAuthor (Person name email time) =
+                ( Author
+                    { authorName  = TE.decodeUtf8 name
+                    , authorEmail =
+                        case emailAddress email of
+                            Nothing ->
+                                error $ "Invalid email " ++ T.unpack (TE.decodeUtf8 email)
+                            Just e  -> e
+                    }
+                , let Elapsed (Seconds t) = gitTimeUTC time
+                  in  posixSecondsToUTCTime $ fromIntegral t
+                )
+
+postReceive :: IO ()
+postReceive = do
+    cachePath <- getVervisCachePath
+    config <- do
+        mc <- decodeFileStrict' $ cachePath </> hookConfigFileName
+        case mc of
+            Nothing -> die "Parsing hook config failed"
+            Just c -> return c
+    args <- getArgs
+    (sharer, repo) <-
+        case args of
+            [s, r] -> return (T.pack s, T.pack r)
+            _ -> die "Unexpected number of arguments"
+    reportNewCommits config sharer repo

src/Vervis/Path.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.
  -
@@ -24,23 +24,24 @@ where
 
 import Data.Text (Text)
 import System.FilePath ((</>))
-import Yesod.Core.Handler (getsYesod)
 
 import qualified Data.CaseInsensitive as CI (foldedCase)
 import qualified Data.Text as T (unpack)
 
+import Yesod.MonadSite
+
 import Vervis.Foundation
 import Vervis.Model.Ident
 import Vervis.Settings
 
-askRepoRootDir :: Handler FilePath
+askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath
-askRepoRootDir = getsYesod $ appRepoDir . appSettings
+askRepoRootDir = asksSite $ appRepoDir . appSettings
 
 sharerDir :: FilePath -> ShrIdent -> FilePath
 sharerDir root sharer =
     root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
 
-askSharerDir :: ShrIdent -> Handler FilePath
+askSharerDir :: (MonadSite m, SiteEnv m ~ App) => ShrIdent -> m FilePath
 askSharerDir sharer = do
     root <- askRepoRootDir
     return $ sharerDir root sharer
@@ -49,7 +50,8 @@ repoDir :: FilePath -> ShrIdent -> RpIdent -> FilePath
 repoDir root sharer repo =
     sharerDir root sharer </> (T.unpack $ CI.foldedCase $ unRpIdent repo)
 
-askRepoDir :: ShrIdent -> RpIdent -> Handler FilePath
+askRepoDir
+    :: (MonadSite m, SiteEnv m ~ App) => ShrIdent -> RpIdent -> m FilePath
 askRepoDir sharer repo = do
     root <- askRepoRootDir
     return $ repoDir root sharer repo

src/Vervis/Settings.hs

@@ -41,6 +41,7 @@ import Data.Yaml                   (decodeEither')
 import Database.Persist.Postgresql (PostgresConf)
 import Language.Haskell.TH.Syntax  (Exp, Name, Q)
 import Network.Wai.Handler.Warp    (HostPreference)
+import System.FilePath
 import Text.Pandoc.Highlighting
 import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
@@ -53,6 +54,7 @@ import Yesod.Mail.Send (MailSettings)
 import Network.FedURI
 
 import Vervis.FedURI
+import Vervis.Settings.TH
 
 developmentMode :: Bool
 developmentMode =
@@ -131,6 +133,8 @@ data AppSettings = AppSettings
     , appRepoDir                :: FilePath
       -- | Number of context lines to display around changes in commit diff
     , appDiffContextLines       :: Int
+      -- | Path of the Vervis post-receive hook executable
+    , appPostReceiveHookFile    :: FilePath
       -- | Port for the SSH server component to listen on
     , appSshPort                :: Int
       -- | Path to the server's SSH private key file
@@ -224,6 +228,7 @@ instance FromJSON AppSettings where
 
         appRepoDir                <- o .: "repo-dir"
         appDiffContextLines       <- o .: "diff-context-lines"
+        appPostReceiveHookFile    <- o .:? "post-receive-hook" .!= detectedHookFile
         appSshPort                <- o .: "ssh-port"
         appSshKeyFile             <- o .: "ssh-key-file"
         appRegister               <- o .: "registration"
@@ -251,6 +256,7 @@ instance FromJSON AppSettings where
         toSeconds :: TimeInterval -> Second
         toSeconds = toTimeUnit
         ndt = fromIntegral . toSeconds . interval
+        detectedHookFile = $localInstallRoot </> "bin" </> "vervis-post-receive"
 
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.

src/Vervis/Settings/TH.hs

@@ -0,0 +1,32 @@
+{- 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/>.
+ -}
+
+module Vervis.Settings.TH
+    ( localInstallRoot
+    )
+where
+
+import Data.Char
+import Data.List
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+import System.Process
+
+localInstallRoot :: Q Exp
+localInstallRoot =
+    stringE . stripSpace =<<
+        runIO (readProcess "stack" ["path", "--local-install-root"] "")
+    where
+    stripSpace = dropWhileEnd isSpace . dropWhile isSpace

stack.yaml

@@ -43,6 +43,7 @@ extra-deps:
   - patience-0.2.1.1
   - pwstore-fast-2.4.4
   - sandi-0.5
+  - email-validate-json-0.1.0.0
   - time-interval-0.1.1
   - time-units-1.0.0
   - url-2.1.3

vervis.cabal

@@ -54,6 +54,7 @@ library
                        Data.ByteString.Local
                        Data.CaseInsensitive.Local
                        Data.Char.Local
+                       Data.DList.Local
                        Data.Either.Local
                        Data.EventTime.Local
                        Data.Functor.Local
@@ -168,6 +169,7 @@ library
                        Vervis.Handler.Ticket
                        Vervis.Handler.Wiki
                        Vervis.Handler.Workflow
+                       Vervis.Hook
                        Vervis.KeyFile
                        Vervis.Migration
                        Vervis.Migration.Model
@@ -192,6 +194,7 @@ library
                        Vervis.Secure
                        Vervis.Settings
                        Vervis.Settings.StaticFiles
+                       Vervis.Settings.TH
                        Vervis.SourceTree
                        Vervis.Ssh
                        Vervis.Style
@@ -270,6 +273,7 @@ library
                      , directory-tree
                      , dlist
                      , email-validate
+                     , email-validate-json
                      , esqueleto
                      , exceptions
                      , fast-logger
@@ -347,6 +351,8 @@ library
                      , transformers
                        -- probably should be replaced with lenses once I learn
                      , tuple
+                       -- For making git hooks executable, i.e. set file mode
+                     , unix
                        -- For httpAPEither
                      , unliftio-core
                      , unliftio
@@ -391,6 +397,13 @@ executable vervis
   if flag(library-only)
     buildable: False
 
+executable vervis-post-receive
+  main-is:             main.hs
+  build-depends:       base, vervis
+  hs-source-dirs:      hook
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
 test-suite test
   main-is:             Spec.hs
   default-extensions:  TemplateHaskell