From 68e8b094a0d0c6c0f21b3697851f416b0765f509 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 9 Sep 2019 00:27:45 +0000 Subject: [PATCH] Handle post-receive hook, publish a Push activity --- config/models | 6 + config/routes | 4 + migrations/2019_09_06.model | 10 ++ src/Vervis/API.hs | 84 +++++++++- src/Vervis/ActivityPub.hs | 3 + src/Vervis/Federation.hs | 23 +++ src/Vervis/Federation/Auth.hs | 45 +++--- src/Vervis/Form/Repo.hs | 2 + src/Vervis/Foundation.hs | 4 + src/Vervis/Handler/Inbox.hs | 26 +++ src/Vervis/Handler/Person.hs | 2 +- src/Vervis/Handler/Repo.hs | 259 ++++++++++++++++++++++++++---- src/Vervis/Handler/Repo/Darcs.hs | 2 +- src/Vervis/Handler/Repo/Git.hs | 2 +- src/Vervis/Handler/Sharer.hs | 23 +++ src/Vervis/Hook.hs | 18 ++- src/Vervis/Migration.hs | 42 +++++ src/Vervis/Migration/Model.hs | 7 + src/Vervis/Ssh.hs | 3 + src/Web/ActivityPub.hs | 49 ++++-- templates/repo/collab/list.hamlet | 2 +- templates/repo/list.hamlet | 2 +- 22 files changed, 545 insertions(+), 73 deletions(-) create mode 100644 migrations/2019_09_06.model diff --git a/config/models b/config/models index 4e2804e..6ad47d2 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/config/routes b/config/routes index 6165849..b4a86bf 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/migrations/2019_09_06.model b/migrations/2019_09_06.model new file mode 100644 index 0000000..4a09fa0 --- /dev/null +++ b/migrations/2019_09_06.model @@ -0,0 +1,10 @@ +Inbox + +FollowerSet + +Repo + inbox InboxId + followers FollowerSetId + +Person + followers FollowerSetId diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 31f86aa..3885777 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 21b0de3..f8bec5b 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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] diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 5bb2bc7..0f17a70 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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] diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index ffe0558..eed51e5 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -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 diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index 43f7fec..f98979c 100644 --- a/src/Vervis/Form/Repo.hs +++ b/src/Vervis/Form/Repo.hs @@ -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 = diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 8b8bff4..3a11c63 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 55e06ac..216930c 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index e69fc17..669b8c2 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 2f97f92..e874996 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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` - 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.select $ E.from $ \ (collab `E.InnerJoin` + person `E.InnerJoin` + sharer `E.LeftOuterJoin` + role) -> do + 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| +

+ #{shr2text shrUser} + \ pushed #{total} # + \ #{commitsText mbranch total} to repo # + #{rp2text rp}^{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 # + #{branch} + |] diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index 8dcdbaa..e43e09a 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -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 diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index a058ee2..9f34884 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -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 diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index dbca530..40b2af5 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -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 diff --git a/src/Vervis/Hook.hs b/src/Vervis/Hook.hs index d151430..95c0113 100644 --- a/src/Vervis/Hook.hs +++ b/src/Vervis/Hook.hs @@ -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2a6159f..7b47f2d 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index e946768..d6464c1 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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") diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 2e1b965..366147f 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -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" diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 179d19c..c686bf7 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -31,6 +31,7 @@ module Web.ActivityPub , Owner (..) , PublicKey (..) , Actor (..) + , Repo (..) , Project (..) , CollectionType (..) , Collection (..) @@ -175,22 +176,25 @@ 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 parseJSON = withText "ActorType" $ pure . parse where parse t - | t == "Person" = ActorTypePerson - | t == "Project" = ActorTypeProject - | otherwise = ActorTypeOther t + | t == "Person" = ActorTypePerson + | t == "Repository" = ActorTypeRepo + | t == "Project" = ActorTypeProject + | otherwise = ActorTypeOther t instance ToJSON ActorType where toJSON = error "toJSON ActorType" 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 diff --git a/templates/repo/collab/list.hamlet b/templates/repo/collab/list.hamlet index 4bda84b..9b3acb1 100644 --- a/templates/repo/collab/list.hamlet +++ b/templates/repo/collab/list.hamlet @@ -16,7 +16,7 @@ $# . Collaborator Role - $forall (Entity _sid sharer, Value mrl) <- devs + $forall (Entity _sid sharer, E.Value mrl) <- devs ^{sharerLinkW sharer} diff --git a/templates/repo/list.hamlet b/templates/repo/list.hamlet index 71e83f6..b3deee3 100644 --- a/templates/repo/list.hamlet +++ b/templates/repo/list.hamlet @@ -15,7 +15,7 @@ $# .

These are the repositories shared by #{shr2text user}.