sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:44:52 +09:00
Code Issues Activity

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

Browse source 
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 2019-09-05 12:02:42 +00:00
parent 29354ff1ed
commit 3c01f4136c
19 changed files with 513 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
config/routes
View file

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

1
config/settings-default.yaml
View file

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

49
src/Data/Git/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -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

8
src/Data/List/NonEmpty/Local.hs
View file

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

6
src/Vervis/API.hs
View file

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

11
src/Vervis/Application.hs
View file

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

25
src/Vervis/Foundation.hs
View file

@ -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
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 host -> handler
_ -> invalidArgs [hostMismatch host bs]
[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)

31
src/Vervis/Git.hs
View file

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

19
src/Vervis/Handler/Repo.hs
View file

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

2
src/Vervis/Handler/Repo/Darcs.hs
View file

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

1
src/Vervis/Handler/Repo/Git.hs
View file

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

14
src/Vervis/Path.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -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

6
src/Vervis/Settings.hs
View file

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

1
stack.yaml
View file

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

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