Handle post-receive hook, publish a Push activity
This commit is contained in:
fr33domlover
parent
3c01f4136c
commit
68e8b094a0
22 changed files with 545 additions and 73 deletions
|
|
@ -36,12 +36,14 @@ Person
|
|||
about Text
|
||||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
|
||||
UniquePersonIdent ident
|
||||
UniquePersonLogin login
|
||||
UniquePersonEmail email
|
||||
UniquePersonInbox inbox
|
||||
UniquePersonOutbox outbox
|
||||
UniquePersonFollowers followers
|
||||
|
||||
Outbox
|
||||
|
||||
|
|
@ -235,8 +237,12 @@ Repo
|
|||
mainBranch Text
|
||||
collabUser RoleId Maybe
|
||||
collabAnon RoleId Maybe
|
||||
inbox InboxId
|
||||
followers FollowerSetId
|
||||
|
||||
UniqueRepo ident sharer
|
||||
UniqueRepoInbox inbox
|
||||
UniqueRepoFollowers followers
|
||||
|
||||
Workflow
|
||||
sharer SharerId
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@
|
|||
/s/#ShrIdent/notifications NotificationsR GET POST
|
||||
/s/#ShrIdent/outbox SharerOutboxR GET POST
|
||||
/s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET
|
||||
/s/#ShrIdent/followers SharerFollowersR GET
|
||||
|
||||
/p PeopleR GET
|
||||
|
||||
|
|
@ -84,6 +85,9 @@
|
|||
/s/#ShrIdent/r ReposR GET POST
|
||||
/s/#ShrIdent/r/!new RepoNewR GET
|
||||
/s/#ShrIdent/r/#RpIdent RepoR GET PUT DELETE POST
|
||||
/s/#ShrIdent/r/#RpIdent/inbox RepoInboxR GET POST
|
||||
/s/#ShrIdent/r/#RpIdent/team RepoTeamR GET
|
||||
/s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET
|
||||
/s/#ShrIdent/r/#RpIdent/edit RepoEditR GET
|
||||
/s/#ShrIdent/r/#RpIdent/s/+Texts RepoSourceR GET
|
||||
/s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET
|
||||
|
|
|
|||
10
migrations/2019_09_06.model
Normal file
10
migrations/2019_09_06.model
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
Inbox
|
||||
|
||||
FollowerSet
|
||||
|
||||
Repo
|
||||
inbox InboxId
|
||||
followers FollowerSetId
|
||||
|
||||
Person
|
||||
followers FollowerSetId
|
||||
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.API
|
||||
( createNoteC
|
||||
, offerTicketC
|
||||
, pushCommitsC
|
||||
, getFollowersCollection
|
||||
)
|
||||
where
|
||||
|
|
@ -691,6 +692,87 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
return remotes
|
||||
|
||||
pushCommitsC
|
||||
:: (Entity Person, Sharer)
|
||||
-> Html
|
||||
-> Push URIMode
|
||||
-> ShrIdent
|
||||
-> RpIdent
|
||||
-> Handler (Either Text OutboxItemId)
|
||||
pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
(obiid, doc, remotesHttp) <- runDBExcept $ do
|
||||
(obiid, doc) <- lift $ insertToOutbox
|
||||
remoteRecips <- lift $ deliverLocal obiid
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled but remote collection members found"
|
||||
remotesHttp <- lift $ deliverRemoteDB' dont obiid [] remoteRecips
|
||||
return (obiid, doc, remotesHttp)
|
||||
lift $ forkWorker "pushCommitsC: async HTTP delivery" $ deliverRemoteHttp dont obiid doc remotesHttp
|
||||
return obiid
|
||||
where
|
||||
insertToOutbox :: AppDB (OutboxItemId, Doc Activity URIMode)
|
||||
insertToOutbox = do
|
||||
host <- getsYesod siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let shrUser = sharerIdent sharer
|
||||
aud = map encodeRouteHome
|
||||
[ SharerFollowersR shrUser
|
||||
, RepoTeamR shrRepo rpRepo
|
||||
, RepoFollowersR shrRepo rpRepo
|
||||
]
|
||||
activity mluAct = Doc host Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary =
|
||||
Just $ TextHtml $ TL.toStrict $ renderHtml summary
|
||||
, activityAudience = Audience aud [] [] [] [] []
|
||||
, activitySpecific = PushActivity push
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = personOutbox $ entityVal eperson
|
||||
, outboxItemActivity = persistJSONObjectFromDoc $ activity Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = activity $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc)
|
||||
|
||||
deliverLocal
|
||||
:: OutboxItemId
|
||||
-> AppDB
|
||||
[ ( (InstanceId, Host)
|
||||
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
|
||||
)
|
||||
]
|
||||
deliverLocal obiid = do
|
||||
let pidAuthor = entityKey eperson
|
||||
(sidRepo, repo) <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRepo
|
||||
r <- getValBy404 $ UniqueRepo rpRepo sid
|
||||
return (sid, r)
|
||||
(pids, remotes) <- do
|
||||
(repoPids, repoRemotes) <- getRepoTeam sidRepo
|
||||
(pfsPids, pfsRemotes) <-
|
||||
getFollowers $ personFollowers $ entityVal eperson
|
||||
(rfsPids, rfsRemotes) <- getFollowers $ repoFollowers repo
|
||||
return
|
||||
( L.delete pidAuthor $ union repoPids $ union pfsPids rfsPids
|
||||
, repoRemotes `unionRemotes` pfsRemotes `unionRemotes` rfsRemotes
|
||||
)
|
||||
ibiid <- insert $ InboxItem False
|
||||
insert_ $ InboxItemLocal (repoInbox repo) obiid ibiid
|
||||
for_ pids $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True
|
||||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
return remotes
|
||||
|
||||
getFollowersCollection
|
||||
:: Route App -> AppDB FollowerSetId -> Handler TypedContent
|
||||
getFollowersCollection here getFsid = do
|
||||
|
|
@ -725,4 +807,4 @@ getFollowersCollection here getFsid = do
|
|||
map (encodeRouteHome . SharerR) locals ++
|
||||
map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
|
||||
}
|
||||
provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
|
||||
provideHtmlAndAP followersAP $ redirectToPrettyJSON here
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ module Vervis.ActivityPub
|
|||
, getPersonOrGroupId
|
||||
, getTicketTeam
|
||||
, getProjectTeam
|
||||
, getRepoTeam
|
||||
, getFollowers
|
||||
, unionRemotes
|
||||
, insertMany'
|
||||
|
|
@ -211,6 +212,8 @@ getTicketTeam sid = do
|
|||
|
||||
getProjectTeam = getTicketTeam
|
||||
|
||||
getRepoTeam = getTicketTeam
|
||||
|
||||
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
|
||||
getFollowers fsid = do
|
||||
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.Federation
|
||||
( handleSharerInbox
|
||||
, handleProjectInbox
|
||||
, handleRepoInbox
|
||||
, fixRunningDeliveries
|
||||
, retryOutboxDelivery
|
||||
)
|
||||
|
|
@ -253,6 +254,28 @@ handleProjectInbox now shrRecip prjRecip auth body = do
|
|||
projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
|
||||
_ -> return "Unsupported activity type"
|
||||
|
||||
handleRepoInbox
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> RpIdent
|
||||
-> ActivityAuthentication
|
||||
-> ActivityBody
|
||||
-> ExceptT Text Handler Text
|
||||
handleRepoInbox now shrRecip rpRecip auth body = do
|
||||
remoteAuthor <-
|
||||
case auth of
|
||||
ActivityAuthLocalPerson pid ->
|
||||
throwE $
|
||||
"Repo inbox got local forwarded activity by pid#" <>
|
||||
T.pack (show $ fromSqlKey pid)
|
||||
ActivityAuthLocalProject jid ->
|
||||
throwE $
|
||||
"Repo inbox got local forwarded activity by jid#" <>
|
||||
T.pack (show $ fromSqlKey jid)
|
||||
ActivityAuthRemote ra -> return ra
|
||||
case activitySpecific $ actbActivity body of
|
||||
_ -> return "Unsupported activity type"
|
||||
|
||||
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
|
||||
fixRunningDeliveries = do
|
||||
c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
|
||||
|
|
|
|||
|
|
@ -320,13 +320,39 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
|
|||
mkauth (Left pid) = ActivityAuthLocalPerson pid
|
||||
mkauth (Right jid) = ActivityAuthLocalProject jid
|
||||
|
||||
verifyContentTypeAP :: MonadHandler m => m ()
|
||||
verifyContentTypeAP = do
|
||||
result <- runExceptT verifyContentTypeAP_E
|
||||
case result of
|
||||
Left e -> invalidArgs ["Content type error: " <> e]
|
||||
Right () -> return ()
|
||||
|
||||
verifyContentTypeAP_E :: MonadHandler m => ExceptT Text m ()
|
||||
verifyContentTypeAP_E = do
|
||||
ctypes <- lookupHeaders "Content-Type"
|
||||
case ctypes of
|
||||
[] -> throwE "Content-Type not specified"
|
||||
[x] | x == typeAS -> return ()
|
||||
| x == typeAS2 -> return ()
|
||||
| otherwise ->
|
||||
throwE $ "Not a recognized AP Content-Type: " <>
|
||||
case decodeUtf8' x of
|
||||
Left _ -> T.pack (show x)
|
||||
Right t -> t
|
||||
_ -> throwE "More than one Content-Type specified"
|
||||
where
|
||||
typeAS = "application/activity+json"
|
||||
typeAS2 =
|
||||
"application/ld+json; \
|
||||
\profile=\"https://www.w3.org/ns/activitystreams\""
|
||||
|
||||
authenticateActivity
|
||||
:: UTCTime
|
||||
-- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
|
||||
-> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
|
||||
authenticateActivity now = do
|
||||
(ra, wv, body) <- do
|
||||
verifyContentType
|
||||
verifyContentTypeAP_E
|
||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
|
||||
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
|
||||
let requires = [hRequestTarget, hHost, hDigest]
|
||||
|
|
@ -371,23 +397,6 @@ authenticateActivity now = do
|
|||
Just a -> return a
|
||||
return (auth, ActivityBody body raw activity)
|
||||
where
|
||||
verifyContentType = do
|
||||
ctypes <- lookupHeaders "Content-Type"
|
||||
case ctypes of
|
||||
[] -> throwE "Content-Type not specified"
|
||||
[x] | x == typeAS -> return ()
|
||||
| x == typeAS2 -> return ()
|
||||
| otherwise ->
|
||||
throwE $ "Not a recognized AP Content-Type: " <>
|
||||
case decodeUtf8' x of
|
||||
Left _ -> T.pack (show x)
|
||||
Right t -> t
|
||||
_ -> throwE "More than one Content-Type specified"
|
||||
where
|
||||
typeAS = "application/activity+json"
|
||||
typeAS2 =
|
||||
"application/ld+json; \
|
||||
\profile=\"https://www.w3.org/ns/activitystreams\""
|
||||
verifyBodyDigest = do
|
||||
req <- waiRequest
|
||||
let headers = W.requestHeaders req
|
||||
|
|
|
|||
|
|
@ -99,6 +99,8 @@ editRepoAForm sid (Entity rid repo) = Repo
|
|||
)
|
||||
<*> aopt selectRole "User role" (Just $ repoCollabUser repo)
|
||||
<*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo)
|
||||
<*> pure (repoInbox repo)
|
||||
<*> pure (repoFollowers repo)
|
||||
where
|
||||
selectProject' = selectProjectForExisting (repoSharer repo) rid
|
||||
selectRole =
|
||||
|
|
|
|||
|
|
@ -604,6 +604,7 @@ instance AccountDB AccountPersistDB' where
|
|||
Right sid -> do
|
||||
ibid <- insert Inbox
|
||||
obid <- insert Outbox
|
||||
fsid <- insert FollowerSet
|
||||
let defTime = UTCTime (ModifiedJulianDay 0) 0
|
||||
person = Person
|
||||
{ personIdent = sid
|
||||
|
|
@ -618,6 +619,7 @@ instance AccountDB AccountPersistDB' where
|
|||
, personAbout = ""
|
||||
, personInbox = ibid
|
||||
, personOutbox = obid
|
||||
, personFollowers = fsid
|
||||
}
|
||||
pid <- insert person
|
||||
return $ Right $ Entity pid person
|
||||
|
|
@ -738,6 +740,8 @@ instance YesodBreadcrumbs App where
|
|||
SharerOutboxItemR shr hid -> ( "#" <> keyHashidText hid
|
||||
, Just $ SharerOutboxR shr
|
||||
)
|
||||
SharerFollowersR shr -> ("Followers", Just $ SharerR shr)
|
||||
|
||||
ActorKey1R -> ("Actor Key 1", Nothing)
|
||||
ActorKey2R -> ("Actor Key 2", Nothing)
|
||||
|
||||
|
|
|
|||
|
|
@ -17,8 +17,10 @@ module Vervis.Handler.Inbox
|
|||
( getInboxR
|
||||
, getSharerInboxR
|
||||
, getProjectInboxR
|
||||
, getRepoInboxR
|
||||
, postSharerInboxR
|
||||
, postProjectInboxR
|
||||
, postRepoInboxR
|
||||
, getPublishR
|
||||
, getSharerOutboxR
|
||||
, getSharerOutboxItemR
|
||||
|
|
@ -283,6 +285,15 @@ getProjectInboxR shr prj = getInbox here getInboxId
|
|||
j <- getValBy404 $ UniqueProject prj sid
|
||||
return $ projectInbox j
|
||||
|
||||
getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoInboxR shr rp = getInbox here getInboxId
|
||||
where
|
||||
here = RepoInboxR shr rp
|
||||
getInboxId = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
r <- getValBy404 $ UniqueRepo rp sid
|
||||
return $ repoInbox r
|
||||
|
||||
postSharerInboxR :: ShrIdent -> Handler ()
|
||||
postSharerInboxR shrRecip = do
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
|
|
@ -326,6 +337,21 @@ postProjectInboxR shrRecip prjRecip = do
|
|||
Left _ -> sendResponseStatus badRequest400 ()
|
||||
Right _ -> return ()
|
||||
|
||||
postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
|
||||
postRepoInboxR shrRecip rpRecip = do
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless federation badMethod
|
||||
contentTypes <- lookupHeaders "Content-Type"
|
||||
now <- liftIO getCurrentTime
|
||||
result <- runExceptT $ do
|
||||
(auth, body) <- authenticateActivity now
|
||||
(actbObject body,) <$>
|
||||
handleRepoInbox now shrRecip rpRecip auth body
|
||||
recordActivity now result contentTypes
|
||||
case result of
|
||||
Left _ -> sendResponseStatus badRequest400 ()
|
||||
Right _ -> return ()
|
||||
|
||||
{-
|
||||
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
|
||||
jsonField = checkMMap fromTextarea toTextarea textareaField
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ getPerson shr sharer person = do
|
|||
, actorSummary = Nothing
|
||||
, actorInbox = encodeRouteLocal $ SharerInboxR shr
|
||||
, actorOutbox = Just $ encodeRouteLocal $ SharerOutboxR shr
|
||||
, actorFollowers = Nothing
|
||||
, actorFollowers = Just $ encodeRouteLocal $ SharerFollowersR shr
|
||||
, actorPublicKeys =
|
||||
[ Left $ encodeRouteLocal ActorKey1R
|
||||
, Left $ encodeRouteLocal ActorKey2R
|
||||
|
|
|
|||
|
|
@ -34,14 +34,18 @@ module Vervis.Handler.Repo
|
|||
, deleteRepoDevR
|
||||
, postRepoDevR
|
||||
, getDarcsDownloadR
|
||||
, getRepoTeamR
|
||||
, getRepoFollowersR
|
||||
|
||||
, getHighlightStyleR
|
||||
, postPostReceiveR
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger (logWarn)
|
||||
import Data.Bifunctor
|
||||
import Data.Git.Graph
|
||||
import Data.Git.Harder
|
||||
import Data.Git.Named (RefName (..))
|
||||
|
|
@ -49,16 +53,16 @@ import Data.Git.Ref (toHex)
|
|||
import Data.Git.Repository
|
||||
import Data.Git.Storage (withRepo)
|
||||
import Data.Git.Storage.Object (Object (..))
|
||||
import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
|
||||
import Data.Git.Types (Blob (..), Person (..), entName)
|
||||
import Data.Graph.Inductive.Graph (noNodes)
|
||||
import Data.Graph.Inductive.Query.Topsort
|
||||
import Data.List (inits)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Traversable (for)
|
||||
import Database.Esqueleto hiding (delete, (%))
|
||||
import Database.Persist (delete)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Data.Hourglass (timeConvert)
|
||||
import Formatting (sformat, stext, (%))
|
||||
import System.Directory
|
||||
|
|
@ -73,45 +77,62 @@ import Yesod.Form.Functions (runFormPost)
|
|||
import Yesod.Form.Types (FormResult (..))
|
||||
import Yesod.Persist.Core (runDB, getBy404)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL (ByteString)
|
||||
import qualified Data.CaseInsensitive as CI (foldedCase)
|
||||
import qualified Data.DList as D
|
||||
import qualified Data.Set as S (member)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Data.MediaType
|
||||
import Web.ActivityPub hiding (Repo)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
import Yesod.RenderSource
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Data.ByteString.Char8.Local (takeLine)
|
||||
import Data.Either.Local
|
||||
import Data.Git.Local
|
||||
import Database.Persist.Local
|
||||
import Text.FilePath.Local (breakExt)
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import qualified Data.Git.Local as G (createRepo)
|
||||
import qualified Darcs.Local.Repository as D (createRepo)
|
||||
|
||||
import Vervis.API
|
||||
import Vervis.Form.Repo
|
||||
import Vervis.Foundation
|
||||
import Vervis.Handler.Repo.Darcs
|
||||
import Vervis.Handler.Repo.Git
|
||||
import Vervis.Path
|
||||
import Data.MediaType
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
import Vervis.Paginate
|
||||
import Vervis.Readme
|
||||
import Yesod.RenderSource
|
||||
import Vervis.Settings
|
||||
import Vervis.SourceTree
|
||||
import Vervis.Style
|
||||
import Vervis.Widget.Repo
|
||||
import Vervis.Widget.Sharer
|
||||
|
||||
import qualified Darcs.Local.Repository as D (createRepo)
|
||||
import qualified Data.ByteString.Lazy as BL (ByteString)
|
||||
import qualified Data.Git.Local as G (createRepo)
|
||||
import qualified Vervis.Formatting as F
|
||||
import qualified Vervis.Hook as H
|
||||
|
||||
getReposR :: ShrIdent -> Handler Html
|
||||
getReposR user = do
|
||||
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
|
||||
where_ $
|
||||
sharer ^. SharerIdent ==. val user &&.
|
||||
sharer ^. SharerId ==. repo ^. RepoSharer
|
||||
orderBy [asc $ repo ^. RepoIdent]
|
||||
return $ repo ^. RepoIdent
|
||||
repos <- runDB $ E.select $ E.from $ \ (sharer, repo) -> do
|
||||
E.where_ $
|
||||
sharer E.^. SharerIdent E.==. E.val user E.&&.
|
||||
sharer E.^. SharerId E.==. repo E.^. RepoSharer
|
||||
E.orderBy [E.asc $ repo E.^. RepoIdent]
|
||||
return $ repo E.^. RepoIdent
|
||||
defaultLayout $(widgetFile "repo/list")
|
||||
|
||||
postReposR :: ShrIdent -> Handler Html
|
||||
|
|
@ -137,6 +158,8 @@ postReposR user = do
|
|||
(rp2text $ nrpIdent nrp)
|
||||
pid <- requireAuthId
|
||||
runDB $ do
|
||||
ibid <- insert Inbox
|
||||
fsid <- insert FollowerSet
|
||||
let repo = Repo
|
||||
{ repoIdent = nrpIdent nrp
|
||||
, repoSharer = sid
|
||||
|
|
@ -146,6 +169,8 @@ postReposR user = do
|
|||
, repoMainBranch = "master"
|
||||
, repoCollabUser = Nothing
|
||||
, repoCollabAnon = Nothing
|
||||
, repoInbox = ibid
|
||||
, repoFollowers = fsid
|
||||
}
|
||||
rid <- insert repo
|
||||
let collab = RepoCollab
|
||||
|
|
@ -175,14 +200,30 @@ selectRepo shar repo = do
|
|||
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
||||
return r
|
||||
|
||||
getRepoR :: ShrIdent -> RpIdent -> Handler Html
|
||||
getRepoR shar repo = do
|
||||
repository <- runDB $ selectRepo shar repo
|
||||
case repoVcs repository of
|
||||
VCSDarcs -> getDarcsRepoSource repository shar repo []
|
||||
VCSGit ->
|
||||
getGitRepoSource
|
||||
repository shar repo (repoMainBranch repository) []
|
||||
getRepoR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoR shr rp = do
|
||||
repo <- runDB $ selectRepo shr rp
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let repoAP = AP.Repo
|
||||
{ AP.repoActor = Actor
|
||||
{ actorId = encodeRouteLocal $ RepoR shr rp
|
||||
, actorType = ActorTypeRepo
|
||||
, actorUsername = Nothing
|
||||
, actorName = Just $ rp2text rp
|
||||
, actorSummary = repoDesc repo
|
||||
, actorInbox = encodeRouteLocal $ RepoInboxR shr rp
|
||||
, actorOutbox = Nothing
|
||||
, actorFollowers =
|
||||
Just $ encodeRouteLocal $ RepoFollowersR shr rp
|
||||
, actorPublicKeys = []
|
||||
}
|
||||
, AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
|
||||
}
|
||||
dir = case repoVcs repo of
|
||||
VCSDarcs -> []
|
||||
VCSGit -> [repoMainBranch repo]
|
||||
provideHtmlAndAP repoAP $ redirect $ RepoSourceR shr rp dir
|
||||
|
||||
putRepoR :: ShrIdent -> RpIdent -> Handler Html
|
||||
putRepoR shr rp = do
|
||||
|
|
@ -293,15 +334,15 @@ getRepoDevsR shr rp = do
|
|||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||||
Entity r _ <- getBy404 $ UniqueRepo rp s
|
||||
return r
|
||||
select $ from $ \ (collab `InnerJoin`
|
||||
person `InnerJoin`
|
||||
sharer `LeftOuterJoin`
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin`
|
||||
person `E.InnerJoin`
|
||||
sharer `E.LeftOuterJoin`
|
||||
role) -> do
|
||||
on $ collab ^. RepoCollabRole ==. role ?. RoleId
|
||||
on $ person ^. PersonIdent ==. sharer ^. SharerId
|
||||
on $ collab ^. RepoCollabPerson ==. person ^. PersonId
|
||||
where_ $ collab ^. RepoCollabRepo ==. val rid
|
||||
return (sharer, role ?. RoleIdent)
|
||||
E.on $ collab E.^. RepoCollabRole E.==. role E.?. RoleId
|
||||
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
||||
E.on $ collab E.^. RepoCollabPerson E.==. person E.^. PersonId
|
||||
E.where_ $ collab E.^. RepoCollabRepo E.==. E.val rid
|
||||
return (sharer, role E.?. RoleIdent)
|
||||
defaultLayout $(widgetFile "repo/collab/list")
|
||||
|
||||
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
||||
|
|
@ -377,6 +418,53 @@ postRepoDevR shr rp dev = do
|
|||
Just "DELETE" -> deleteRepoDevR shr rp dev
|
||||
_ -> notFound
|
||||
|
||||
getRepoTeamR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoTeamR shr rp = do
|
||||
memberShrs <- runDB $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
_rid <- getKeyBy404 $ UniqueRepo rp sid
|
||||
id_ <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniquePersonIdent sid)
|
||||
(getKeyBy $ UniqueGroup sid)
|
||||
"Found sharer that is neither person nor group"
|
||||
"Found sharer that is both person and group"
|
||||
case id_ of
|
||||
Left pid -> return [shr]
|
||||
Right gid -> do
|
||||
pids <-
|
||||
map (groupMemberPerson . entityVal) <$>
|
||||
selectList [GroupMemberGroup ==. gid] []
|
||||
sids <-
|
||||
map (personIdent . entityVal) <$>
|
||||
selectList [PersonId <-. pids] []
|
||||
map (sharerIdent . entityVal) <$>
|
||||
selectList [SharerId <-. sids] []
|
||||
|
||||
let here = RepoTeamR shr rp
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let team = Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ length memberShrs
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
|
||||
}
|
||||
provideHtmlAndAP team $ redirectToPrettyJSON here
|
||||
|
||||
getRepoFollowersR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoFollowersR shr rp = getFollowersCollection here getFsid
|
||||
where
|
||||
here = RepoFollowersR shr rp
|
||||
getFsid = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
r <- getValBy404 $ UniqueRepo rp sid
|
||||
return $ repoFollowers r
|
||||
|
||||
getHighlightStyleR :: Text -> Handler TypedContent
|
||||
getHighlightStyleR styleName =
|
||||
case lookup (unpack styleName) highlightingStyles of
|
||||
|
|
@ -384,5 +472,108 @@ getHighlightStyleR styleName =
|
|||
Just style ->
|
||||
return $ TypedContent typeCss $ toContent $ styleToCss style
|
||||
|
||||
postPostReceiveR :: Handler ()
|
||||
postPostReceiveR = error "TODO post-receive handler not implemented yet"
|
||||
postPostReceiveR :: Handler Text
|
||||
postPostReceiveR = do
|
||||
push <- requireCheckJsonBody
|
||||
(pushAP, shr, rp) <- push2ap push
|
||||
user <- runDB $ do
|
||||
p <- getJustEntity $ toSqlKey $ H.pushUser push
|
||||
s <- getJust $ personIdent $ entityVal p
|
||||
return (p, s)
|
||||
let shrUser = sharerIdent $ snd user
|
||||
summary <- do
|
||||
let mbranch = H.pushBranch push
|
||||
total = pushCommitsTotal pushAP
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrUser}>#{shr2text shrUser}
|
||||
\ pushed #{total} #
|
||||
\ #{commitsText mbranch total} to repo #
|
||||
<a href=@{RepoR shr rp}>#{rp2text rp}</a>^{branchText shr rp mbranch}.
|
||||
|]
|
||||
eid <- pushCommitsC user summary pushAP shr rp
|
||||
case eid of
|
||||
Left e -> liftIO $ throwIO $ userError $ T.unpack e
|
||||
Right obiid -> do
|
||||
renderUrl <- askUrlRender
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
return $
|
||||
"Push activity published: " <>
|
||||
renderUrl (SharerOutboxItemR shrUser obikhid)
|
||||
where
|
||||
push2ap (H.Push secret _ sharer repo mbranch mbefore after early mlate) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let shr = text2shr sharer
|
||||
rp = text2rp repo
|
||||
commit2ap' = commit2ap shr rp
|
||||
(commitsLast, commitsFirst) <-
|
||||
runDB $ case mlate of
|
||||
Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
|
||||
Just (_omitted, late) ->
|
||||
(,) <$> traverse commit2ap' late
|
||||
<*> (Just <$> traverse commit2ap' early)
|
||||
return
|
||||
( Push
|
||||
{ pushCommitsLast = commitsLast
|
||||
, pushCommitsFirst = commitsFirst
|
||||
, pushCommitsTotal =
|
||||
case mlate of
|
||||
Nothing -> length early
|
||||
Just (omitted, late) ->
|
||||
length early + omitted + length late
|
||||
, pushTarget =
|
||||
encodeRouteLocal $
|
||||
case mbranch of
|
||||
Nothing -> RepoR shr rp
|
||||
Just b -> RepoBranchR shr rp b
|
||||
, pushHashBefore = mbefore
|
||||
, pushHashAfter = after
|
||||
}
|
||||
, shr
|
||||
, rp
|
||||
)
|
||||
where
|
||||
commit2ap shr rp (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
author <- authorByEmail wauthor
|
||||
mcommitter <- traverse (authorByEmail . fst) mcommitted
|
||||
return Commit
|
||||
{ commitId = encodeRouteLocal $ RepoPatchR shr rp hash
|
||||
, commitRepository = encodeRouteLocal $ RepoR shr rp
|
||||
, commitAuthor = second (encodeRouteHome . SharerR) author
|
||||
, commitCommitter =
|
||||
second (encodeRouteHome . SharerR) <$> mcommitter
|
||||
, commitTitle = title
|
||||
, commitHash = Hash $ encodeUtf8 hash
|
||||
, commitDescription =
|
||||
if T.null desc
|
||||
then Nothing
|
||||
else Just desc
|
||||
, commitWritten = wtime
|
||||
, commitCommitted = snd <$> mcommitted
|
||||
}
|
||||
where
|
||||
authorByEmail (H.Author name email) = do
|
||||
mperson <- getValBy $ UniquePersonEmail email
|
||||
case mperson of
|
||||
Nothing -> return $ Left $ Author name email
|
||||
Just person ->
|
||||
Right . sharerIdent <$> getJust (personIdent person)
|
||||
commitsText :: Maybe a -> Int -> Text
|
||||
commitsText Nothing n =
|
||||
if n > 1
|
||||
then "patches"
|
||||
else "patch"
|
||||
commitsText (Just _) n =
|
||||
if n > 1
|
||||
then "commits"
|
||||
else "commit"
|
||||
--branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
|
||||
branchText _ _ Nothing = const mempty
|
||||
branchText shr rp (Just branch) =
|
||||
[hamlet|
|
||||
, branch #
|
||||
<a href=@{RepoBranchR shr rp branch}>#{branch}
|
||||
|]
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
||||
|
||||
import Data.MediaType
|
||||
import Web.ActivityPub
|
||||
import Web.ActivityPub hiding (Repo)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.RenderSource
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
||||
|
||||
import Data.MediaType
|
||||
import Web.ActivityPub hiding (Commit, Author)
|
||||
import Web.ActivityPub hiding (Commit, Author, Repo)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.RenderSource
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.Handler.Sharer
|
||||
( getSharersR
|
||||
, getSharerR
|
||||
, getSharerFollowersR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -30,6 +31,10 @@ import Yesod.Core.Content (TypedContent)
|
|||
import Yesod.Core.Handler (redirect, notFound)
|
||||
import Yesod.Persist.Core (runDB, getBy404)
|
||||
|
||||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.API
|
||||
import Vervis.Foundation
|
||||
import Vervis.Handler.Person
|
||||
import Vervis.Handler.Group
|
||||
|
|
@ -64,3 +69,21 @@ getSharerR shr = do
|
|||
case ent of
|
||||
Left (Entity _ p) -> getPerson shr s p
|
||||
Right (Entity _ g) -> getGroup shr g
|
||||
|
||||
getSharerFollowersR :: ShrIdent -> Handler TypedContent
|
||||
getSharerFollowersR shr = getFollowersCollection here getFsid
|
||||
where
|
||||
here = SharerFollowersR shr
|
||||
getFsid = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
mval <- runMaybeT
|
||||
$ Left <$> MaybeT (getValBy $ UniquePersonIdent sid)
|
||||
<|> Right <$> MaybeT (getValBy $ UniqueGroup sid)
|
||||
case mval of
|
||||
Nothing -> do
|
||||
$logWarn $ "Found non-person non-group sharer: " <> shr2text shr
|
||||
notFound
|
||||
Just val ->
|
||||
case val of
|
||||
Left person -> return $ personFollowers person
|
||||
Right _group -> notFound
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ import Data.Git.Graph
|
|||
import Data.Git.Harder
|
||||
import Data.Graph.Inductive.Graph -- (noNodes)
|
||||
import Data.Graph.Inductive.Query.Topsort
|
||||
import Data.Int
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
|
|
@ -49,6 +50,7 @@ import Data.Time.Clock.POSIX
|
|||
import Data.Word
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Types.Header
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
|
|
@ -57,6 +59,7 @@ import System.IO
|
|||
import Text.Email.Aeson.Instances ()
|
||||
import Text.Email.Validate
|
||||
import Time.Types
|
||||
import Yesod.Core.Content
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
|
|
@ -122,9 +125,12 @@ instance ToJSON Commit
|
|||
|
||||
data Push = Push
|
||||
{ pushSecret :: Text
|
||||
, pushUser :: Int64
|
||||
, pushSharer :: Text
|
||||
, pushRepo :: Text
|
||||
, pushBranch :: Maybe Text
|
||||
, pushBefore :: Maybe Text
|
||||
, pushAfter :: Text
|
||||
, pushInit :: NonEmpty Commit
|
||||
, pushLast :: Maybe (Int, NonEmpty Commit)
|
||||
}
|
||||
|
|
@ -148,10 +154,11 @@ writeHookConfig config = do
|
|||
|
||||
reportNewCommits :: Config -> Text -> Text -> IO ()
|
||||
reportNewCommits config sharer repo = do
|
||||
user <- read <$> getEnv "VERVIS_SSH_USER"
|
||||
manager <- newManager defaultManagerSettings
|
||||
withRepo "." $ loop manager
|
||||
withRepo "." $ loop user manager
|
||||
where
|
||||
loop manager git = do
|
||||
loop user manager git = do
|
||||
eof <- isEOF
|
||||
unless eof $ do
|
||||
result <- runExceptT $ do
|
||||
|
|
@ -205,9 +212,12 @@ reportNewCommits config sharer repo = do
|
|||
return (eNE, Just (middle, lNE))
|
||||
let push = Push
|
||||
{ pushSecret = configSecret config
|
||||
, pushUser = user
|
||||
, pushSharer = sharer
|
||||
, pushRepo = repo
|
||||
, pushBranch = Just branch
|
||||
, pushBefore = old <$ moldRef
|
||||
, pushAfter = new
|
||||
, pushInit = early
|
||||
, pushLast = late
|
||||
}
|
||||
|
|
@ -219,6 +229,7 @@ reportNewCommits config sharer repo = do
|
|||
req <- requestFromURI $ uriFromObjURI uri
|
||||
let req' =
|
||||
setRequestCheckStatus $
|
||||
consHeader hContentType typeJson $
|
||||
req { method = "POST"
|
||||
, requestBody = RequestBodyLBS $ encode push
|
||||
}
|
||||
|
|
@ -227,10 +238,11 @@ reportNewCommits config sharer repo = do
|
|||
case result of
|
||||
Left e -> TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
|
||||
Right _resp -> return ()
|
||||
loop manager git
|
||||
loop user manager git
|
||||
where
|
||||
adaptErr :: HttpException -> Text
|
||||
adaptErr = T.pack . displayException
|
||||
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
||||
parseRef t =
|
||||
if t == nullRef
|
||||
then return Nothing
|
||||
|
|
|
|||
|
|
@ -1008,6 +1008,48 @@ changes hLocal ctx =
|
|||
"summary"
|
||||
-- 129
|
||||
, addFieldPrimRequired "TicketDependency" defaultTime "created"
|
||||
-- 130
|
||||
, addFieldRefRequired'
|
||||
"Repo"
|
||||
FollowerSet130
|
||||
(Just $ do
|
||||
rids <- selectKeysList ([] :: [Filter Repo130]) []
|
||||
for_ rids $ \ rid -> do
|
||||
fsid <- insert FollowerSet130
|
||||
update rid [Repo130Followers =. fsid]
|
||||
)
|
||||
"followers"
|
||||
"FollowerSet"
|
||||
-- 131
|
||||
, addUnique "Repo" $ Unique "UniqueRepoFollowers" ["followers"]
|
||||
-- 132
|
||||
, addFieldRefRequired'
|
||||
"Repo"
|
||||
Inbox130
|
||||
(Just $ do
|
||||
rids <- selectKeysList ([] :: [Filter Repo130]) []
|
||||
for_ rids $ \ rid -> do
|
||||
ibid <- insert Inbox130
|
||||
update rid [Repo130Inbox =. ibid]
|
||||
)
|
||||
"inbox"
|
||||
"Inbox"
|
||||
-- 133
|
||||
, addUnique "Repo" $ Unique "UniqueRepoInbox" ["inbox"]
|
||||
-- 134
|
||||
, addFieldRefRequired'
|
||||
"Person"
|
||||
FollowerSet130
|
||||
(Just $ do
|
||||
pids <- selectKeysList ([] :: [Filter Person130]) []
|
||||
for_ pids $ \ pid -> do
|
||||
fsid <- insert FollowerSet130
|
||||
update pid [Person130Followers =. fsid]
|
||||
)
|
||||
"followers"
|
||||
"FollowerSet"
|
||||
-- 135
|
||||
, addUnique "Person" $ Unique "UniquePersonFollowers" ["followers"]
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -118,6 +118,10 @@ module Vervis.Migration.Model
|
|||
, Ticket127Generic (..)
|
||||
, TicketDependency127Generic (..)
|
||||
, TicketDependency127
|
||||
, Inbox130Generic (..)
|
||||
, FollowerSet130Generic (..)
|
||||
, Repo130
|
||||
, Person130
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -239,3 +243,6 @@ makeEntitiesMigration "20190624"
|
|||
|
||||
makeEntitiesMigration "127"
|
||||
$(modelFile "migrations/2019_07_11.model")
|
||||
|
||||
makeEntitiesMigration "130"
|
||||
$(modelFile "migrations/2019_09_06.model")
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ import Network.SSH.Channel
|
|||
import Network.SSH.Crypto
|
||||
import Network.SSH.Session
|
||||
import System.Directory (doesFileExist, doesDirectoryExist)
|
||||
import System.Environment
|
||||
import System.FilePath ((</>))
|
||||
import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
|
||||
|
||||
|
|
@ -263,6 +264,8 @@ runAction repoDir _wantReply action =
|
|||
can <- canPushTo sharer repo
|
||||
if can
|
||||
then whenGitRepoExists True repoPath $ do
|
||||
pid <- authId <$> askAuthDetails
|
||||
liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid)
|
||||
execute "git-receive-pack" [repoPath]
|
||||
return ARProcess
|
||||
else return $ ARFail "You can't push to this repository"
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ module Web.ActivityPub
|
|||
, Owner (..)
|
||||
, PublicKey (..)
|
||||
, Actor (..)
|
||||
, Repo (..)
|
||||
, Project (..)
|
||||
, CollectionType (..)
|
||||
, Collection (..)
|
||||
|
|
@ -175,7 +176,8 @@ instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where
|
|||
context [t] = "@context" .= t
|
||||
context ts = "@context" .= ts
|
||||
|
||||
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
|
||||
data ActorType =
|
||||
ActorTypePerson | ActorTypeRepo | ActorTypeProject | ActorTypeOther Text
|
||||
deriving Eq
|
||||
|
||||
instance FromJSON ActorType where
|
||||
|
|
@ -183,6 +185,7 @@ instance FromJSON ActorType where
|
|||
where
|
||||
parse t
|
||||
| t == "Person" = ActorTypePerson
|
||||
| t == "Repository" = ActorTypeRepo
|
||||
| t == "Project" = ActorTypeProject
|
||||
| otherwise = ActorTypeOther t
|
||||
|
||||
|
|
@ -191,6 +194,7 @@ instance ToJSON ActorType where
|
|||
toEncoding at =
|
||||
toEncoding $ case at of
|
||||
ActorTypePerson -> "Person"
|
||||
ActorTypeRepo -> "Repository"
|
||||
ActorTypeProject -> "Project"
|
||||
ActorTypeOther t -> t
|
||||
|
||||
|
|
@ -307,6 +311,24 @@ instance ActivityPub Actor where
|
|||
<> "followers" .=? (ObjURI authority <$> followers)
|
||||
<> "publicKey" `pair` encodePublicKeySet authority pkeys
|
||||
|
||||
data Repo u = Repo
|
||||
{ repoActor :: Actor u
|
||||
, repoTeam :: LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub Repo where
|
||||
jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
(h, a) <- parseObject o
|
||||
unless (actorType a == ActorTypeRepo) $
|
||||
fail "Actor type isn't Repository"
|
||||
fmap (h,) $
|
||||
Repo a
|
||||
<$> withAuthorityO h (o .:| "team")
|
||||
toSeries authority (Repo actor team)
|
||||
= toSeries authority actor
|
||||
<> "team" .= ObjURI authority team
|
||||
|
||||
data Project u = Project
|
||||
{ projectActor :: Actor u
|
||||
, projectTeam :: LocalURI
|
||||
|
|
@ -1021,10 +1043,11 @@ encodeOffer authority actor (Offer obj target)
|
|||
<> "target" .= target
|
||||
|
||||
data Push u = Push
|
||||
{ pushCommits :: NonEmpty (Commit u)
|
||||
{ pushCommitsLast :: NonEmpty (Commit u)
|
||||
, pushCommitsFirst :: Maybe (NonEmpty (Commit u))
|
||||
, pushCommitsTotal :: Int
|
||||
, pushTarget :: LocalURI
|
||||
, pushHashBefore :: Text
|
||||
, pushHashBefore :: Maybe Text
|
||||
, pushHashAfter :: Text
|
||||
}
|
||||
|
||||
|
|
@ -1033,23 +1056,25 @@ parsePush a o = do
|
|||
c <- o .: "object"
|
||||
Push
|
||||
<$> (traverse (withAuthorityT a . parseObject) =<< c .: "items")
|
||||
<*> (traverse (traverse $ withAuthorityT a . parseObject) =<< c .:? "earlyItems")
|
||||
<*> c .: "totalItems"
|
||||
<*> withAuthorityO a (o .: "target")
|
||||
<*> o .: "hashBefore"
|
||||
<*> o .:? "hashBefore"
|
||||
<*> o .: "hashAfter"
|
||||
|
||||
encodePush :: UriMode u => Authority u -> Push u -> Series
|
||||
encodePush a (Push commits total target before after)
|
||||
encodePush a (Push lateCommits earlyCommits total target before after)
|
||||
= "object" `pair` pairs
|
||||
( "type" .= ("OrderedCollection" :: Text)
|
||||
<> pair
|
||||
"items"
|
||||
(listEncoding (pairs . toSeries a) (NE.toList commits))
|
||||
<> pair "items" (objectList lateCommits)
|
||||
<> maybe mempty (pair "earlyItems" . objectList) earlyCommits
|
||||
<> "totalItems" .= total
|
||||
)
|
||||
<> "target" .= ObjURI a target
|
||||
<> "hashBefore" .= before
|
||||
<> "hashBefore" .=? before
|
||||
<> "hashAfter" .= after
|
||||
where
|
||||
objectList items = listEncoding (pairs . toSeries a) (NE.toList items)
|
||||
|
||||
data Reject u = Reject
|
||||
{ rejectObject :: ObjURI u
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<tr>
|
||||
<th>Collaborator
|
||||
<th>Role
|
||||
$forall (Entity _sid sharer, Value mrl) <- devs
|
||||
$forall (Entity _sid sharer, E.Value mrl) <- devs
|
||||
<tr>
|
||||
<td>^{sharerLinkW sharer}
|
||||
<td>
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<p>These are the repositories shared by #{shr2text user}.
|
||||
|
||||
<ul>
|
||||
$forall Value repo <- repos
|
||||
$forall E.Value repo <- repos
|
||||
<li>
|
||||
<a href=@{RepoR user repo}>#{rp2text repo}
|
||||
<li>
|
||||
|
|
|
|||
Loading…
Reference in a new issue