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:
parent
29354ff1ed
commit
3c01f4136c
19 changed files with 513 additions and 54 deletions
|
@ -22,6 +22,12 @@
|
||||||
|
|
||||||
/highlight/#Text/style.css HighlightStyleR GET
|
/highlight/#Text/style.css HighlightStyleR GET
|
||||||
|
|
||||||
|
-- ----------------------------------------------------------------------------
|
||||||
|
-- Internal
|
||||||
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
/post-receive PostReceiveR POST
|
||||||
|
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
-- Federation
|
-- Federation
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
|
@ -79,6 +79,7 @@ max-actor-keys: 2
|
||||||
|
|
||||||
repo-dir: repos
|
repo-dir: repos
|
||||||
diff-context-lines: 5
|
diff-context-lines: 5
|
||||||
|
#post-receive-hook: /home/joe/.local/bin/vervis-post-receive
|
||||||
|
|
||||||
###############################################################################
|
###############################################################################
|
||||||
# SSH server
|
# 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.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -15,7 +15,8 @@
|
||||||
|
|
||||||
module Data.Git.Local
|
module Data.Git.Local
|
||||||
( -- * Initialize repo
|
( -- * Initialize repo
|
||||||
createRepo
|
writeHookFile
|
||||||
|
, createRepo
|
||||||
-- * View repo content
|
-- * View repo content
|
||||||
, EntObjType (..)
|
, EntObjType (..)
|
||||||
, TreeRows
|
, TreeRows
|
||||||
|
@ -27,8 +28,8 @@ module Data.Git.Local
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Data.Byteable (toBytes)
|
|
||||||
import Data.Git
|
import Data.Git
|
||||||
import Data.Git.Harder
|
import Data.Git.Harder
|
||||||
import Data.Git.Ref (SHA1)
|
import Data.Git.Ref (SHA1)
|
||||||
|
@ -38,11 +39,13 @@ import Data.Text (Text)
|
||||||
import Data.Text.Encoding (decodeUtf8With)
|
import Data.Text.Encoding (decodeUtf8With)
|
||||||
import Data.Text.Encoding.Error (lenientDecode)
|
import Data.Text.Encoding.Error (lenientDecode)
|
||||||
import System.Directory.Tree
|
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.ByteString.Lazy as BL (ByteString)
|
||||||
import qualified Data.Set as S (mapMonotonic)
|
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.EventTime.Local
|
||||||
import Data.Hourglass.Local ()
|
import Data.Hourglass.Local ()
|
||||||
|
@ -51,9 +54,19 @@ instance SpecToEventTime GitTime where
|
||||||
specToEventTime = specToEventTime . gitTimeUTC
|
specToEventTime = specToEventTime . gitTimeUTC
|
||||||
specsToEventTimes = specsToEventTimes . fmap 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" []
|
[ Dir "branches" []
|
||||||
, File "config"
|
, File "config"
|
||||||
"[core]\n\
|
"[core]\n\
|
||||||
|
@ -63,7 +76,9 @@ initialRepoTree repo =
|
||||||
, File "description"
|
, File "description"
|
||||||
"Unnamed repository; edit this file to name the repository."
|
"Unnamed repository; edit this file to name the repository."
|
||||||
, File "HEAD" "ref: refs/heads/master"
|
, File "HEAD" "ref: refs/heads/master"
|
||||||
, Dir "hooks" []
|
, Dir "hooks"
|
||||||
|
[ File "post-receive" $ hookContent hook sharer repo
|
||||||
|
]
|
||||||
, Dir "info"
|
, Dir "info"
|
||||||
[ File "exclude" ""
|
[ File "exclude" ""
|
||||||
]
|
]
|
||||||
|
@ -87,12 +102,20 @@ createRepo
|
||||||
-- ^ Parent directory which already exists
|
-- ^ Parent directory which already exists
|
||||||
-> String
|
-> String
|
||||||
-- ^ Name of new repo, i.e. new directory to create under the parent
|
-- ^ 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 ()
|
-> 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
|
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
|
data EntObjType = EntObjBlob | EntObjTree
|
||||||
|
|
||||||
|
|
|
@ -19,9 +19,11 @@ module Data.List.NonEmpty.Local
|
||||||
, groupWithExtractBy1
|
, groupWithExtractBy1
|
||||||
, groupAllExtract
|
, groupAllExtract
|
||||||
, unionGroupsOrdWith
|
, unionGroupsOrdWith
|
||||||
|
, nonEmptyE
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
import Data.Function
|
import Data.Function
|
||||||
import Data.List.NonEmpty (NonEmpty (..))
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
|
||||||
|
@ -84,3 +86,9 @@ unionGroupsOrdWith groupOrd itemOrd = go
|
||||||
let cs = unionOrdByNE (compare `on` itemOrd) as bs
|
let cs = unionOrdByNE (compare `on` itemOrd) as bs
|
||||||
in (i, cs) : go zs ws
|
in (i, cs) : go zs ws
|
||||||
GT -> (j, bs) : go xs 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
|
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
|
||||||
return lmid
|
return lmid
|
||||||
where
|
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
|
parseRecipsContextParent
|
||||||
:: FedURI
|
:: FedURI
|
||||||
-> Maybe FedURI
|
-> Maybe FedURI
|
||||||
|
|
|
@ -76,6 +76,8 @@ import Web.Hashids.Local
|
||||||
import Vervis.ActorKey (generateActorKey, actorKeyRotator)
|
import Vervis.ActorKey (generateActorKey, actorKeyRotator)
|
||||||
import Vervis.Federation
|
import Vervis.Federation
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
import Vervis.Git
|
||||||
|
import Vervis.Hook
|
||||||
import Vervis.KeyFile (isInitialSetup)
|
import Vervis.KeyFile (isInitialSetup)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
|
|
||||||
|
@ -138,6 +140,8 @@ makeFoundation appSettings = do
|
||||||
|
|
||||||
appInstanceMutex <- newInstanceMutex
|
appInstanceMutex <- newInstanceMutex
|
||||||
|
|
||||||
|
appHookSecret <- generateKey
|
||||||
|
|
||||||
appActorFetchShare <- newResultShare actorFetchShareAction
|
appActorFetchShare <- newResultShare actorFetchShareAction
|
||||||
|
|
||||||
appActivities <-
|
appActivities <-
|
||||||
|
@ -193,6 +197,13 @@ makeFoundation appSettings = do
|
||||||
$logInfo "DB migration success"
|
$logInfo "DB migration success"
|
||||||
fixRunningDeliveries
|
fixRunningDeliveries
|
||||||
deleteUnusedURAs
|
deleteUnusedURAs
|
||||||
|
writePostReceiveHooks
|
||||||
|
|
||||||
|
writeHookConfig Config
|
||||||
|
{ configSecret = hookSecretText appHookSecret
|
||||||
|
, configPort = fromIntegral $ appPort appSettings
|
||||||
|
, configMaxCommits = 20
|
||||||
|
}
|
||||||
|
|
||||||
-- Return the foundation
|
-- Return the foundation
|
||||||
return app
|
return app
|
||||||
|
|
|
@ -93,6 +93,7 @@ import Yesod.Paginate.Local
|
||||||
import Vervis.Access
|
import Vervis.Access
|
||||||
import Vervis.ActorKey
|
import Vervis.ActorKey
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
import Vervis.Hook
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Group
|
import Vervis.Model.Group
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
|
@ -125,6 +126,7 @@ data App = App
|
||||||
, appInstanceMutex :: InstanceMutex
|
, appInstanceMutex :: InstanceMutex
|
||||||
, appCapSignKey :: AccessTokenSecretKey
|
, appCapSignKey :: AccessTokenSecretKey
|
||||||
, appHashidsContext :: HashidsContext
|
, appHashidsContext :: HashidsContext
|
||||||
|
, appHookSecret :: HookSecret
|
||||||
, appActorFetchShare :: ActorFetchShare App
|
, appActorFetchShare :: ActorFetchShare App
|
||||||
|
|
||||||
, appActivities :: Maybe (Int, TVar (Vector ActivityReport))
|
, appActivities :: Maybe (Int, TVar (Vector ActivityReport))
|
||||||
|
@ -202,6 +204,7 @@ instance Yesod App where
|
||||||
handler
|
handler
|
||||||
(getCurrentRoute >>= \ mr -> case mr of
|
(getCurrentRoute >>= \ mr -> case mr of
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
|
Just PostReceiveR -> return False
|
||||||
Just (SharerInboxR _) -> return False
|
Just (SharerInboxR _) -> return False
|
||||||
Just (ProjectInboxR _ _) -> return False
|
Just (ProjectInboxR _ _) -> return False
|
||||||
Just (GitUploadRequestR _ _) -> return False
|
Just (GitUploadRequestR _ _) -> return False
|
||||||
|
@ -211,18 +214,18 @@ instance Yesod App where
|
||||||
defaultCsrfParamName
|
defaultCsrfParamName
|
||||||
)
|
)
|
||||||
. ( \ handler -> do
|
. ( \ 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
|
. defaultYesodMiddleware
|
||||||
where
|
where
|
||||||
|
@ -942,3 +945,5 @@ instance YesodBreadcrumbs App where
|
||||||
)
|
)
|
||||||
|
|
||||||
WikiPageR shr prj _page -> ("Wiki", Just $ ProjectR shr prj)
|
WikiPageR shr prj _page -> ("Wiki", Just $ ProjectR shr prj)
|
||||||
|
|
||||||
|
_ -> ("PAGE TITLE HERE", Nothing)
|
||||||
|
|
|
@ -19,16 +19,18 @@ module Vervis.Git
|
||||||
, listRefs
|
, listRefs
|
||||||
, readPatch
|
, readPatch
|
||||||
, lastCommitTime
|
, lastCommitTime
|
||||||
|
, writePostReceiveHooks
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Patience (diff, Item (..))
|
import Patience (diff, Item (..))
|
||||||
import Data.Byteable (toBytes)
|
import Data.Byteable (toBytes)
|
||||||
import Data.Foldable (foldlM, find)
|
import Data.Foldable
|
||||||
import Data.Git.Diff
|
import Data.Git.Diff
|
||||||
import Data.Git.Graph
|
import Data.Git.Graph
|
||||||
import Data.Git.Harder
|
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 as TE (decodeUtf8With)
|
||||||
import qualified Data.Text.Encoding.Error as TE (lenientDecode)
|
import qualified Data.Text.Encoding.Error as TE (lenientDecode)
|
||||||
import qualified Data.Vector as V (fromList)
|
import qualified Data.Vector as V (fromList)
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
import Yesod.MonadSite
|
||||||
|
|
||||||
import Data.ByteString.Char8.Local (takeLine)
|
import Data.ByteString.Char8.Local (takeLine)
|
||||||
|
import Data.DList.Local
|
||||||
import Data.EventTime.Local
|
import Data.EventTime.Local
|
||||||
import Data.Git.Local
|
import Data.Git.Local
|
||||||
import Data.List.Local
|
import Data.List.Local
|
||||||
|
|
||||||
import Vervis.Changes
|
import Vervis.Changes
|
||||||
import Vervis.Foundation (Widget)
|
import Vervis.Foundation
|
||||||
|
import Vervis.Model
|
||||||
|
import Vervis.Model.Ident
|
||||||
import Vervis.Patch
|
import Vervis.Patch
|
||||||
|
import Vervis.Path
|
||||||
import Vervis.Readme
|
import Vervis.Readme
|
||||||
|
import Vervis.Settings
|
||||||
import Vervis.SourceTree
|
import Vervis.SourceTree
|
||||||
|
|
||||||
matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
|
matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
|
||||||
|
@ -147,10 +158,6 @@ readSourceView path ref dir = do
|
||||||
let toTexts = S.mapMonotonic $ T.pack . refNameRaw
|
let toTexts = S.mapMonotonic $ T.pack . refNameRaw
|
||||||
return (toTexts bs, toTexts ts, renderSources dir <$> msv)
|
return (toTexts bs, toTexts ts, renderSources dir <$> msv)
|
||||||
|
|
||||||
instance ResultList D.DList where
|
|
||||||
emptyList = D.empty
|
|
||||||
appendItem = flip D.snoc
|
|
||||||
|
|
||||||
readChangesView
|
readChangesView
|
||||||
:: FilePath
|
:: FilePath
|
||||||
-- ^ Repository path
|
-- ^ Repository path
|
||||||
|
@ -210,7 +217,7 @@ patch edits c = Patch
|
||||||
in (T.strip l, T.strip r)
|
in (T.strip l, T.strip r)
|
||||||
(title, desc) = split $ decodeUtf8 $ commitMessage c
|
(title, desc) = split $ decodeUtf8 $ commitMessage c
|
||||||
|
|
||||||
makeAuthor (Person name email time) =
|
makeAuthor (G.Person name email time) =
|
||||||
( Author
|
( Author
|
||||||
{ authorName = decodeUtf8 name
|
{ authorName = decodeUtf8 name
|
||||||
, authorEmail =
|
, authorEmail =
|
||||||
|
@ -322,3 +329,13 @@ lastCommitTime repo =
|
||||||
utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
|
utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
|
||||||
utc0 = UTCTime (ModifiedJulianDay 0) 0
|
utc0 = UTCTime (ModifiedJulianDay 0) 0
|
||||||
foldlM' i l f = foldlM f i l
|
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
|
, getDarcsDownloadR
|
||||||
|
|
||||||
, getHighlightStyleR
|
, getHighlightStyleR
|
||||||
|
, postPostReceiveR
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -120,13 +121,20 @@ postReposR user = do
|
||||||
case result of
|
case result of
|
||||||
FormSuccess nrp -> do
|
FormSuccess nrp -> do
|
||||||
parent <- askSharerDir user
|
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
|
pid <- requireAuthId
|
||||||
runDB $ do
|
runDB $ do
|
||||||
let repo = Repo
|
let repo = Repo
|
||||||
|
@ -375,3 +383,6 @@ getHighlightStyleR styleName =
|
||||||
Nothing -> notFound
|
Nothing -> notFound
|
||||||
Just style ->
|
Just style ->
|
||||||
return $ TypedContent typeCss $ toContent $ styleToCss 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 Data.Paginate.Local
|
||||||
import Text.FilePath.Local (breakExt)
|
import Text.FilePath.Local (breakExt)
|
||||||
|
|
||||||
import qualified Darcs.Local.Repository as D (createRepo)
|
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.ChangeFeed (changeFeed)
|
import Vervis.ChangeFeed (changeFeed)
|
||||||
import Vervis.Changes
|
import Vervis.Changes
|
||||||
|
|
|
@ -92,7 +92,6 @@ import Vervis.Widget.Repo
|
||||||
import Vervis.Widget.Sharer
|
import Vervis.Widget.Sharer
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as BL (ByteString)
|
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)
|
import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs, readPatch)
|
||||||
|
|
||||||
getGitRepoSource :: Repo -> ShrIdent -> RpIdent -> Text -> [Text] -> Handler Html
|
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.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -24,23 +24,24 @@ where
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import Yesod.Core.Handler (getsYesod)
|
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI (foldedCase)
|
import qualified Data.CaseInsensitive as CI (foldedCase)
|
||||||
import qualified Data.Text as T (unpack)
|
import qualified Data.Text as T (unpack)
|
||||||
|
|
||||||
|
import Yesod.MonadSite
|
||||||
|
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Settings
|
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 :: FilePath -> ShrIdent -> FilePath
|
||||||
sharerDir root sharer =
|
sharerDir root sharer =
|
||||||
root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
|
root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
|
||||||
|
|
||||||
askSharerDir :: ShrIdent -> Handler FilePath
|
askSharerDir :: (MonadSite m, SiteEnv m ~ App) => ShrIdent -> m FilePath
|
||||||
askSharerDir sharer = do
|
askSharerDir sharer = do
|
||||||
root <- askRepoRootDir
|
root <- askRepoRootDir
|
||||||
return $ sharerDir root sharer
|
return $ sharerDir root sharer
|
||||||
|
@ -49,7 +50,8 @@ repoDir :: FilePath -> ShrIdent -> RpIdent -> FilePath
|
||||||
repoDir root sharer repo =
|
repoDir root sharer repo =
|
||||||
sharerDir root sharer </> (T.unpack $ CI.foldedCase $ unRpIdent 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
|
askRepoDir sharer repo = do
|
||||||
root <- askRepoRootDir
|
root <- askRepoRootDir
|
||||||
return $ repoDir root sharer repo
|
return $ repoDir root sharer repo
|
||||||
|
|
|
@ -41,6 +41,7 @@ import Data.Yaml (decodeEither')
|
||||||
import Database.Persist.Postgresql (PostgresConf)
|
import Database.Persist.Postgresql (PostgresConf)
|
||||||
import Language.Haskell.TH.Syntax (Exp, Name, Q)
|
import Language.Haskell.TH.Syntax (Exp, Name, Q)
|
||||||
import Network.Wai.Handler.Warp (HostPreference)
|
import Network.Wai.Handler.Warp (HostPreference)
|
||||||
|
import System.FilePath
|
||||||
import Text.Pandoc.Highlighting
|
import Text.Pandoc.Highlighting
|
||||||
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
|
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
|
||||||
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
|
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
|
||||||
|
@ -53,6 +54,7 @@ import Yesod.Mail.Send (MailSettings)
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
|
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
import Vervis.Settings.TH
|
||||||
|
|
||||||
developmentMode :: Bool
|
developmentMode :: Bool
|
||||||
developmentMode =
|
developmentMode =
|
||||||
|
@ -131,6 +133,8 @@ data AppSettings = AppSettings
|
||||||
, appRepoDir :: FilePath
|
, appRepoDir :: FilePath
|
||||||
-- | Number of context lines to display around changes in commit diff
|
-- | Number of context lines to display around changes in commit diff
|
||||||
, appDiffContextLines :: Int
|
, appDiffContextLines :: Int
|
||||||
|
-- | Path of the Vervis post-receive hook executable
|
||||||
|
, appPostReceiveHookFile :: FilePath
|
||||||
-- | Port for the SSH server component to listen on
|
-- | Port for the SSH server component to listen on
|
||||||
, appSshPort :: Int
|
, appSshPort :: Int
|
||||||
-- | Path to the server's SSH private key file
|
-- | Path to the server's SSH private key file
|
||||||
|
@ -224,6 +228,7 @@ instance FromJSON AppSettings where
|
||||||
|
|
||||||
appRepoDir <- o .: "repo-dir"
|
appRepoDir <- o .: "repo-dir"
|
||||||
appDiffContextLines <- o .: "diff-context-lines"
|
appDiffContextLines <- o .: "diff-context-lines"
|
||||||
|
appPostReceiveHookFile <- o .:? "post-receive-hook" .!= detectedHookFile
|
||||||
appSshPort <- o .: "ssh-port"
|
appSshPort <- o .: "ssh-port"
|
||||||
appSshKeyFile <- o .: "ssh-key-file"
|
appSshKeyFile <- o .: "ssh-key-file"
|
||||||
appRegister <- o .: "registration"
|
appRegister <- o .: "registration"
|
||||||
|
@ -251,6 +256,7 @@ instance FromJSON AppSettings where
|
||||||
toSeconds :: TimeInterval -> Second
|
toSeconds :: TimeInterval -> Second
|
||||||
toSeconds = toTimeUnit
|
toSeconds = toTimeUnit
|
||||||
ndt = fromIntegral . toSeconds . interval
|
ndt = fromIntegral . toSeconds . interval
|
||||||
|
detectedHookFile = $localInstallRoot </> "bin" </> "vervis-post-receive"
|
||||||
|
|
||||||
-- | Settings for 'widgetFile', such as which template languages to support and
|
-- | Settings for 'widgetFile', such as which template languages to support and
|
||||||
-- default Hamlet settings.
|
-- 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
|
- patience-0.2.1.1
|
||||||
- pwstore-fast-2.4.4
|
- pwstore-fast-2.4.4
|
||||||
- sandi-0.5
|
- sandi-0.5
|
||||||
|
- email-validate-json-0.1.0.0
|
||||||
- time-interval-0.1.1
|
- time-interval-0.1.1
|
||||||
- time-units-1.0.0
|
- time-units-1.0.0
|
||||||
- url-2.1.3
|
- url-2.1.3
|
||||||
|
|
13
vervis.cabal
13
vervis.cabal
|
@ -54,6 +54,7 @@ library
|
||||||
Data.ByteString.Local
|
Data.ByteString.Local
|
||||||
Data.CaseInsensitive.Local
|
Data.CaseInsensitive.Local
|
||||||
Data.Char.Local
|
Data.Char.Local
|
||||||
|
Data.DList.Local
|
||||||
Data.Either.Local
|
Data.Either.Local
|
||||||
Data.EventTime.Local
|
Data.EventTime.Local
|
||||||
Data.Functor.Local
|
Data.Functor.Local
|
||||||
|
@ -168,6 +169,7 @@ library
|
||||||
Vervis.Handler.Ticket
|
Vervis.Handler.Ticket
|
||||||
Vervis.Handler.Wiki
|
Vervis.Handler.Wiki
|
||||||
Vervis.Handler.Workflow
|
Vervis.Handler.Workflow
|
||||||
|
Vervis.Hook
|
||||||
Vervis.KeyFile
|
Vervis.KeyFile
|
||||||
Vervis.Migration
|
Vervis.Migration
|
||||||
Vervis.Migration.Model
|
Vervis.Migration.Model
|
||||||
|
@ -192,6 +194,7 @@ library
|
||||||
Vervis.Secure
|
Vervis.Secure
|
||||||
Vervis.Settings
|
Vervis.Settings
|
||||||
Vervis.Settings.StaticFiles
|
Vervis.Settings.StaticFiles
|
||||||
|
Vervis.Settings.TH
|
||||||
Vervis.SourceTree
|
Vervis.SourceTree
|
||||||
Vervis.Ssh
|
Vervis.Ssh
|
||||||
Vervis.Style
|
Vervis.Style
|
||||||
|
@ -270,6 +273,7 @@ library
|
||||||
, directory-tree
|
, directory-tree
|
||||||
, dlist
|
, dlist
|
||||||
, email-validate
|
, email-validate
|
||||||
|
, email-validate-json
|
||||||
, esqueleto
|
, esqueleto
|
||||||
, exceptions
|
, exceptions
|
||||||
, fast-logger
|
, fast-logger
|
||||||
|
@ -347,6 +351,8 @@ library
|
||||||
, transformers
|
, transformers
|
||||||
-- probably should be replaced with lenses once I learn
|
-- probably should be replaced with lenses once I learn
|
||||||
, tuple
|
, tuple
|
||||||
|
-- For making git hooks executable, i.e. set file mode
|
||||||
|
, unix
|
||||||
-- For httpAPEither
|
-- For httpAPEither
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, unliftio
|
, unliftio
|
||||||
|
@ -391,6 +397,13 @@ executable vervis
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
buildable: False
|
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
|
test-suite test
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
default-extensions: TemplateHaskell
|
default-extensions: TemplateHaskell
|
||||||
|
|
Loading…
Reference in a new issue