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
This commit is contained in:
fr33domlover
parent
29354ff1ed
commit
3c01f4136c
19 changed files with 513 additions and 54 deletions
|
|
@ -22,6 +22,12 @@
|
|||
|
||||
/highlight/#Text/style.css HighlightStyleR GET
|
||||
|
||||
-- ----------------------------------------------------------------------------
|
||||
-- Internal
|
||||
-- ----------------------------------------------------------------------------
|
||||
|
||||
/post-receive PostReceiveR POST
|
||||
|
||||
-- ----------------------------------------------------------------------------
|
||||
-- Federation
|
||||
-- ----------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
19
hook/main.hs
Normal file
19
hook/main.hs
Normal file
|
|
@ -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
|
||||
27
src/Data/DList/Local.hs
Normal file
27
src/Data/DList/Local.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
286
src/Vervis/Hook.hs
Normal file
286
src/Vervis/Hook.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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 = 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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
32
src/Vervis/Settings/TH.hs
Normal file
32
src/Vervis/Settings/TH.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
13
vervis.cabal
13
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue