From 3c01f4136c39d46294417203e727d58511771f38 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 5 Sep 2019 12:02:42 +0000 Subject: [PATCH] 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 | 6 + config/settings-default.yaml | 1 + hook/main.hs | 19 ++ src/Data/DList/Local.hs | 27 +++ src/Data/Git/Local.hs | 49 ++++-- src/Data/List/NonEmpty/Local.hs | 8 + src/Vervis/API.hs | 6 - src/Vervis/Application.hs | 11 ++ src/Vervis/Foundation.hs | 29 ++-- src/Vervis/Git.hs | 31 +++- src/Vervis/Handler/Repo.hs | 25 ++- src/Vervis/Handler/Repo/Darcs.hs | 2 - src/Vervis/Handler/Repo/Git.hs | 1 - src/Vervis/Hook.hs | 286 +++++++++++++++++++++++++++++++ src/Vervis/Path.hs | 14 +- src/Vervis/Settings.hs | 6 + src/Vervis/Settings/TH.hs | 32 ++++ stack.yaml | 1 + vervis.cabal | 13 ++ 19 files changed, 513 insertions(+), 54 deletions(-) create mode 100644 hook/main.hs create mode 100644 src/Data/DList/Local.hs create mode 100644 src/Vervis/Hook.hs create mode 100644 src/Vervis/Settings/TH.hs diff --git a/config/routes b/config/routes index 28a5801..6165849 100644 --- a/config/routes +++ b/config/routes @@ -22,6 +22,12 @@ /highlight/#Text/style.css HighlightStyleR GET +-- ---------------------------------------------------------------------------- +-- Internal +-- ---------------------------------------------------------------------------- + +/post-receive PostReceiveR POST + -- ---------------------------------------------------------------------------- -- Federation -- ---------------------------------------------------------------------------- diff --git a/config/settings-default.yaml b/config/settings-default.yaml index 8378fe1..ace2023 100644 --- a/config/settings-default.yaml +++ b/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 diff --git a/hook/main.hs b/hook/main.hs new file mode 100644 index 0000000..36dcc04 --- /dev/null +++ b/hook/main.hs @@ -0,0 +1,19 @@ +{- 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 + - . + -} + +import Vervis.Hook + +main :: IO () +main = postReceive diff --git a/src/Data/DList/Local.hs b/src/Data/DList/Local.hs new file mode 100644 index 0000000..c24b22a --- /dev/null +++ b/src/Data/DList/Local.hs @@ -0,0 +1,27 @@ +{- 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 + - . + -} + +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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 19483ab..ade7af1 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.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. - @@ -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 -initialRepoTree repo = - Dir repo +hookContent :: FilePath -> Text -> Text -> Text +hookContent hook sharer 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 - let tree = path :/ initialRepoTree name - result <- writeDirectoryWith B.writeFile tree +createRepo path name cmd sharer repo = do + let tree = path :/ initialRepoTree cmd sharer repo name + 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 diff --git a/src/Data/List/NonEmpty/Local.hs b/src/Data/List/NonEmpty/Local.hs index c24defe..7dce6f0 100644 --- a/src/Data/List/NonEmpty/Local.hs +++ b/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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 8d07802..31f86aa 100644 --- a/src/Vervis/API.hs +++ b/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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 9cf0013..1fd9a5e 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 71d3e9c..8b8bff4 100644 --- a/src/Vervis/Foundation.hs +++ b/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 - {- - if developmentMode - then handler - else do - -} - host <- - getsYesod $ - renderAuthority . appInstanceHost . appSettings - bs <- lookupHeaders hHost - case bs of - [b] | b == encodeUtf8 host -> handler - _ -> invalidArgs [hostMismatch host bs] + host <- getsYesod $ renderAuthority . siteInstanceHost + port <- getsYesod $ appPort . appSettings + mroute <- getCurrentRoute + let localhost = "localhost:" <> T.pack (show port) + expectedHost = + case mroute of + Just PostReceiveR -> localhost + _ -> host + bs <- lookupHeaders hHost + case bs of + [b] | b == encodeUtf8 expectedHost -> handler + _ -> 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) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 21c39c6..467e274 100644 --- a/src/Vervis/Git.hs +++ b/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) diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 2a679d1..2f97f92 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 - createDirectoryIfMissing True parent - let repoName = - unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp - case nrpVcs nrp of - VCSDarcs -> D.createRepo parent repoName - VCSGit -> G.createRepo parent repoName + liftIO $ createDirectoryIfMissing True parent + let repoName = + unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp + case nrpVcs nrp of + VCSDarcs -> liftIO $ D.createRepo parent repoName + VCSGit -> do + 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" diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index 4a25116..8dcdbaa 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/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 diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 46a74cf..a058ee2 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/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 diff --git a/src/Vervis/Hook.hs b/src/Vervis/Hook.hs new file mode 100644 index 0000000..d151430 --- /dev/null +++ b/src/Vervis/Hook.hs @@ -0,0 +1,286 @@ +{- 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 + - . + -} + +{-# 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 diff --git a/src/Vervis/Path.hs b/src/Vervis/Path.hs index eb098ba..7714ed4 100644 --- a/src/Vervis/Path.hs +++ b/src/Vervis/Path.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. - @@ -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 = getsYesod $ appRepoDir . appSettings +askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath +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 diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index d1fcfad..eefe5db 100644 --- a/src/Vervis/Settings.hs +++ b/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. diff --git a/src/Vervis/Settings/TH.hs b/src/Vervis/Settings/TH.hs new file mode 100644 index 0000000..6011c35 --- /dev/null +++ b/src/Vervis/Settings/TH.hs @@ -0,0 +1,32 @@ +{- 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 + - . + -} + +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 diff --git a/stack.yaml b/stack.yaml index 7cbe8a7..56278aa 100644 --- a/stack.yaml +++ b/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 diff --git a/vervis.cabal b/vervis.cabal index 5369593..385d988 100644 --- a/vervis.cabal +++ b/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