diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index abcd507..5c46eaf 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -21,10 +21,14 @@ module Data.Aeson.Local , (.:|?) , (.:+) , (.:+?) + , (.:*) + , (.:*+) , (.=?) , (.=%) , (.=+) , (.=+?) + , (.=*) + , (.=*+) , WithValue (..) ) where @@ -32,6 +36,7 @@ where import Control.Applicative import Data.Aeson import Data.Aeson.Types (Parser) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Network.URI @@ -58,7 +63,7 @@ fromEither (Right y) = Right' y (.:|) :: FromJSON a => Object -> Text -> Parser a o .:| t = o .: t <|> o .: (frg <> t) where - frg = "https://forgefed.peers.community/ns#" + frg = "https://forgefed.org/ns#" (.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a) o .:|? t = optional $ o .:| t @@ -71,6 +76,26 @@ o .:+ t = Left <$> o .: t <|> Right <$> o .: t => Object -> Text -> Parser (Maybe (Either a b)) o .:+? t = optional $ o .:+ t +-- | For JSON-LD properties that aren't functional, i.e. can have any number of +-- values +(.:*) :: FromJSON a => Object -> Text -> Parser [a] +o .:* t = do + maybeOneOrArray <- o .:+? t + case maybeOneOrArray of + Nothing -> return [] + Just (Left v) -> return [v] + Just (Right vs) -> return vs + +-- | For JSON-LD properties that aren't functional, i.e. can have any number of +-- values +(.:*+) :: FromJSON a => Object -> Text -> Parser (NonEmpty a) +o .:*+ t = do + oneOrArray <- o .:+ t + case oneOrArray of + Left v -> return $ v :| [] + Right [] -> fail $ "No values for " ++ T.unpack t + Right (v:vs) -> return $ v :| vs + infixr 8 .=? (.=?) :: ToJSON v => Text -> Maybe v -> Series _ .=? Nothing = mempty @@ -93,6 +118,17 @@ infixr 8 .=+? k .=+? Nothing = mempty k .=+? (Just v) = k .=+ v +infixr 8 .=* +(.=*) :: ToJSON a => Text -> [a] -> Series +_ .=* [] = mempty +k .=* [v] = k .= v +k .=* vs = k .= vs + +infixr 8 .=*+ +(.=*+) :: ToJSON a => Text -> NonEmpty a -> Series +k .=*+ (v :| []) = k .= v +k .=*+ (v :| vs) = k .= (v:vs) + data WithValue a = WithValue { wvRaw :: Object , wvParsed :: a diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 0b33fba..9ee4758 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -22,6 +22,7 @@ module Vervis.API , applyC , noteC , createNoteC + , createPatchTrackerC , createRepositoryC , createTicketTrackerC , followC @@ -1277,6 +1278,276 @@ verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips = guard $ localRecipRepo $ localRecipRepoDirect repoSet -} +createPatchTrackerC + :: Entity Person + -> Actor + -> Maybe TextHtml + -> Audience URIMode + -> AP.ActorDetail + -> NonEmpty FedURI + -> Maybe (Host, AP.ActorLocal URIMode) + -> Maybe FedURI + -> ExceptT Text Handler OutboxItemId +createPatchTrackerC (Entity pidUser personUser) senderActor summary audience detail repos mlocal muTarget = do + + -- Check input + verifyNothingE mlocal "'id' not allowed in new PatchTracker to create" + (name, msummary) <- parseDetail detail + repoID <- parseRepo repos + senderHash <- encodeKeyHashid pidUser + now <- liftIO getCurrentTime + verifyNothingE muTarget "'target' not supported in Create PatchTracker" + ParsedAudience localRecips remoteRecips blinded fwdHosts <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "Create PatchTracker with no recipients" + checkFederation remoteRecips + + (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do + + -- Find the specified repo in DB + _ <- getE repoID "No such repo in DB" + + -- Make sure the repo has a single, full-access collab, granted to the + -- sender of this Create + maybeApproved <- lift $ runMaybeT $ do + collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] + collabID <- + case collabs of + [Entity _ c] -> return $ collabTopicRepoCollab c + _ -> mzero + CollabRecipLocal _ recipID <- + MaybeT $ getValBy $ UniqueCollabRecipLocal collabID + guard $ recipID == pidUser + _ <- MaybeT $ getBy $ UniqueCollabEnable collabID + _ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID + return () + unless (isJust maybeApproved) $ + throwE "Repo's collabs unexpected state" + + -- Insert new loom to DB + obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + (loomID, Entity loomActorID loomActor) <- + lift $ insertLoom now name msummary obiidCreate repoID + + -- Insert the Create activity to author's outbox + loomHash <- encodeKeyHashid loomID + repoHash <- encodeKeyHashid repoID + docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash + + -- Deliver the Create activity to local recipients, and schedule + -- delivery for unavailable remote recipients + remoteRecipsHttpCreate <- do + let sieve = + makeRecipientSet + [LocalActorRepo repoHash] + [ LocalStagePersonFollowers senderHash + , LocalStageRepoFollowers repoHash + ] + moreRemoteRecips <- + lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $ + localRecipSieve sieve False localRecips + checkFederation moreRemoteRecips + lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips + + -- Insert collaboration access for loom's creator + let loomOutboxID = actorOutbox loomActor + obiidGrant <- lift $ insertEmptyOutboxItem loomOutboxID now + lift $ insertCollab loomID obiidGrant + + -- Insert a Grant activity to loom's outbox + let grantRecipActors = [LocalActorPerson senderHash] + grantRecipStages = [LocalStagePersonFollowers senderHash] + docGrant <- + lift $ insertGrantToOutbox senderHash loomHash obiidCreate obiidGrant grantRecipActors grantRecipStages + + -- Deliver the Grant activity to local recipients, and schedule + -- delivery for unavailable remote recipients + remoteRecipsHttpGrant <- do + remoteRecips <- + lift $ deliverLocal' True (LocalActorLoom loomHash) loomActorID obiidGrant $ + makeRecipientSet grantRecipActors grantRecipStages + checkFederation remoteRecips + lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips + + -- Insert follow record + obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + obiidAccept <- lift $ insertEmptyOutboxItem loomOutboxID now + lift $ insert_ $ Follow (personActor personUser) (actorFollowers loomActor) True obiidFollow obiidAccept + + -- Insert a Follow activity to sender's outbox, and an Accept to the + -- loom's outbox + luFollow <- lift $ insertFollowToOutbox senderHash loomHash obiidFollow + lift $ insertAcceptToOutbox senderHash loomHash obiidAccept luFollow + + -- Deliver the Follow and Accept by simply manually inserting them to + -- loom and sender inboxes respectively + lift $ do + ibiidF <- insert $ InboxItem False now + insert_ $ InboxItemLocal (actorInbox loomActor) obiidFollow ibiidF + ibiidA <- insert $ InboxItem False now + insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA + + -- Return instructions for HTTP delivery to remote recipients + return + ( obiidCreate + , deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate + , deliverRemoteHttp' [] obiidGrant docGrant remoteRecipsHttpGrant + ) + + -- Launch asynchronous HTTP delivery of Create and Grant + lift $ do + forkWorker "createPatchTrackerC: async HTTP Create delivery" deliverHttpCreate + forkWorker "createPatchTrackerC: async HTTP Grant delivery" deliverHttpGrant + + return obiid + + where + + parseDetail (AP.ActorDetail typ muser mname msummary) = do + unless (typ == AP.ActorTypePatchTracker) $ + error "createPatchTrackerC: Create object isn't a PatchTracker" + verifyNothingE muser "PatchTracker can't have a username" + name <- fromMaybeE mname "PatchTracker doesn't specify name" + return (name, msummary) + + parseRepo (ObjURI h lu :| us) = do + unless (null us) $ throwE "More than one repo is specified" + hl <- hostIsLocal h + unless hl $ throwE "A remote repo is specified" + route <- fromMaybeE (decodeRouteLocal lu) "Not a valid route" + case route of + RepoR repoHash -> decodeKeyHashidE repoHash "Invalid repo hash" + _ -> throwE "Not a repo route" + + insertLoom now name msummary obiidCreate repoID = do + actor@(Entity actorID _) <- + insertActor now name (fromMaybe "" msummary) + loomID <- insert Loom + { loomNextTicket = 1 + , loomActor = actorID + , loomRepo = repoID + , loomCreate = obiidCreate + } + return (loomID, actor) + + insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhid <- encodeKeyHashid obiidCreate + let ptdetail = AP.ActorDetail + { AP.actorType = AP.ActorTypePatchTracker + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = msummary + } + ptlocal = AP.ActorLocal + { AP.actorId = encodeRouteLocal $ LoomR loomHash + , AP.actorInbox = encodeRouteLocal $ LoomInboxR loomHash + , AP.actorOutbox = Nothing + , AP.actorFollowers = Nothing + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = [] + , AP.actorSshKeys = [] + } + repo = encodeRouteHome $ RepoR repoHash + create = Doc hLocal Activity + { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid + , activityActor = encodeRouteLocal $ PersonR senderHash + , activityCapability = Nothing + , activitySummary = summary + , activityAudience = blinded + , activityFulfills = [] + , activitySpecific = CreateActivity Create + { createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal)) + , createTarget = Nothing + } + } + update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] + return create + + insertCollab loomID obiidGrant = do + cid <- insert Collab + insert_ $ CollabTopicLoom cid loomID + insert_ $ CollabEnable cid obiidGrant + insert_ $ CollabRecipLocal cid pidUser + insert_ $ CollabFulfillsLocalTopicCreation cid + + insertGrantToOutbox adminHash loomHash obiidCreate obiidGrant actors stages = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhidCreate <- encodeKeyHashid obiidCreate + obikhidGrant <- encodeKeyHashid obiidGrant + let recips = + map encodeRouteHome $ + map renderLocalActor actors ++ + map renderLocalStage stages + grant = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + LoomOutboxItemR loomHash obikhidGrant + , activityActor = encodeRouteLocal $ LoomR loomHash + , activityCapability = Nothing + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activityFulfills = + [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] + , activitySpecific = GrantActivity Grant + { grantObject = Left RoleAdmin + , grantContext = encodeRouteHome $ LoomR loomHash + , grantTarget = encodeRouteHome $ PersonR adminHash + } + } + update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant] + return grant + + insertFollowToOutbox senderHash loomHash obiidFollow = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + + obikhid <- encodeKeyHashid obiidFollow + let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid + recips = [encodeRouteHome $ LoomR loomHash] + doc = Doc hLocal Activity + { activityId = Just luFollow + , activityActor = encodeRouteLocal $ PersonR senderHash + , activityCapability = Nothing + , activitySummary = Nothing + , activityAudience = AP.Audience recips [] [] [] [] [] + , activityFulfills = [] + , activitySpecific = FollowActivity AP.Follow + { AP.followObject = encodeRouteHome $ LoomR loomHash + , AP.followContext = Nothing + , AP.followHide = False + } + } + update obiidFollow [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return luFollow + + insertAcceptToOutbox senderHash loomHash obiidAccept luFollow = do + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + + obikhid <- encodeKeyHashid obiidAccept + + let recips = [encodeRouteHome $ PersonR senderHash] + doc = Doc hLocal Activity + { activityId = Just $ encodeRouteLocal $ LoomOutboxItemR loomHash obikhid + , activityActor = encodeRouteLocal $ LoomR loomHash + , activityCapability = Nothing + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activityFulfills = [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hLocal luFollow + , acceptResult = Nothing + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + createRepositoryC :: Entity Person -> Actor @@ -1399,6 +1670,7 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai , repoCollabAnon = Nothing , repoActor = actorID , repoCreate = createID + , repoLoom = Nothing } return (repoID, actor) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index d212785..67e28b6 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -30,6 +30,7 @@ module Vervis.Client --, unresolve --, offerMR createDeck + , createLoom , createRepo ) where @@ -38,6 +39,7 @@ import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Data.Bitraversable +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) import Database.Persist @@ -621,6 +623,37 @@ createDeck senderHash name desc = do return (Nothing, AP.Audience recips [] [] [] [] [], detail) +createLoom + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => KeyHashid Person + -> Text + -> Text + -> KeyHashid Repo + -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, NonEmpty FedURI) +createLoom senderHash name desc repoHash = do + encodeRouteHome <- getEncodeRouteHome + + let audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + audRepo = + AudLocal + [LocalActorRepo repoHash] + [LocalStageRepoFollowers repoHash] + + (_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audRepo] + + recips = map encodeRouteHome audLocal ++ audRemote + + detail = AP.ActorDetail + { AP.actorType = AP.ActorTypePatchTracker + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = Just desc + } + repo = encodeRouteHome $ RepoR repoHash + + return (Nothing, AP.Audience recips [] [] [] [] [], detail, repo :| []) + createRepo :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => KeyHashid Person diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 71a4ed8..c2337b7 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -16,6 +16,8 @@ module Vervis.Form.Project ( NewProject (..) , newProjectForm + , NewLoom (..) + , newLoomForm --, NewProjectCollab (..) --, newProjectCollabForm --, editProjectForm @@ -31,8 +33,11 @@ import Yesod.Form.Functions import Yesod.Form.Types import Yesod.Persist.Core +import qualified Data.Text as T import qualified Database.Esqueleto as E +import Yesod.Hashids + import Vervis.Foundation import Vervis.Model @@ -46,6 +51,33 @@ newProjectForm = renderDivs $ NewProject <$> areq textField "Name*" Nothing <*> areq textField "Description" Nothing +data NewLoom = NewLoom + { nlName :: Text + , nlDesc :: Text + , nlRepo :: RepoId + } + +newLoomForm :: Form NewLoom +newLoomForm = renderDivs $ NewLoom + <$> areq textField "Name*" Nothing + <*> areq textField "Description" Nothing + <*> areq selectRepo "Repo*" Nothing + where + selectRepo = selectField $ do + hashRepo <- getEncodeKeyHashid + l <- runDB $ E.select $ + E.from $ \ (repo `E.InnerJoin` actor) -> do + E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId + E.where_ $ E.isNothing $ repo E.^. RepoLoom + E.orderBy [E.desc $ repo E.^. RepoId] + return (actor E.^. ActorName, repo E.^. RepoId) + optionsPairs $ map (option hashRepo) l + where + option hashRepo (E.Value name, E.Value repoID) = + ( T.concat ["^", keyHashidText $ hashRepo repoID, " ", name] + , repoID + ) + {- data NewProjectCollab = NewProjectCollab { ncPerson :: PersonId diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 0d564fa..b16ca7b 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -21,15 +21,21 @@ module Vervis.Handler.Loom , getLoomOutboxItemR , getLoomFollowersR , getLoomClothsR + + , getLoomNewR + , postLoomNewR + , postLoomFollowR + , postLoomUnfollowR ) where import Control.Monad import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Aeson import Data.ByteString (ByteString) import Data.Foldable -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Text (Text) import Data.Time.Clock import Data.Traversable @@ -59,6 +65,7 @@ import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.Paginate.Local import Database.Persist.Local +import Yesod.Form.Local import Yesod.Persist.Local import Vervis.Access @@ -66,6 +73,7 @@ import Vervis.API import Vervis.Federation.Auth import Vervis.Federation.Collab import Vervis.FedURI +import Vervis.Form.Project import Vervis.Foundation import Vervis.Model import Vervis.Paginate @@ -73,6 +81,8 @@ import Vervis.Recipient import Vervis.Settings import Vervis.Web.Actor +import qualified Vervis.Client as C + getLoomR :: KeyHashid Loom -> Handler TypedContent getLoomR loomHash = do loomID <- decodeKeyHashid404 loomHash @@ -220,3 +230,71 @@ getLoomClothsR loomHash = selectRep $ do where here = LoomClothsR loomHash encodeStrict = BL.toStrict . encode + +getLoomNewR :: Handler Html +getLoomNewR = do + ((_result, widget), enctype) <- runFormPost newLoomForm + defaultLayout + [whamlet| +
+ ^{widget} +
+ + |] + +postLoomNewR :: Handler Html +postLoomNewR = do + (NewLoom name desc repoID, _widget, _enctype) <- + runFormPostRedirect LoomNewR newLoomForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + repoHash <- encodeKeyHashid repoID + (maybeSummary, audience, detail, repos) <- + C.createLoom personHash name desc repoHash + actor <- runDB $ do + + -- Find the specified repo in DB + _ <- getJust repoID + + -- Make sure the repo has a single, full-access collab, granted to the + -- creator of the loom + maybeApproved <- runMaybeT $ do + collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] + collabID <- + case collabs of + [Entity _ c] -> return $ collabTopicRepoCollab c + _ -> mzero + CollabRecipLocal _ recipID <- + MaybeT $ getValBy $ UniqueCollabRecipLocal collabID + guard $ recipID == personID + _ <- MaybeT $ getBy $ UniqueCollabEnable collabID + _ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID + return () + unless (isJust maybeApproved) $ do + setMessage "Can't link with the repo chosen" + redirect LoomNewR + + getJust $ personActor person + + result <- + runExceptT $ createPatchTrackerC personEntity actor maybeSummary audience detail repos Nothing Nothing + + case result of + Left e -> do + setMessage $ toHtml e + redirect LoomNewR + Right createID -> do + maybeLoomID <- runDB $ getKeyBy $ UniqueLoomCreate createID + case maybeLoomID of + Nothing -> error "Can't find the newly created loom" + Just loomID -> do + loomHash <- encodeKeyHashid loomID + setMessage "New patch tracker created" + redirect $ LoomR loomHash + +postLoomFollowR :: KeyHashid Loom -> Handler () +postLoomFollowR _ = error "Temporarily disabled" + +postLoomUnfollowR :: KeyHashid Loom -> Handler () +postLoomUnfollowR _ = error "Temporarily disabled" diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 4fe9ee6..8296c47 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -284,6 +284,8 @@ postPersonOutboxR personHash = do createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget AP.CreateRepository detail vcs mlocal -> createRepositoryC eperson actorDB summary audience detail vcs mlocal mtarget + AP.CreatePatchTracker detail repos mlocal -> + createPatchTrackerC eperson actorDB summary audience detail repos mlocal mtarget _ -> throwE "Unsupported Create 'object' type" AP.InviteActivity invite -> inviteC eperson actorDB mcap summary audience invite diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 086bf21..8a99107 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -42,6 +42,8 @@ module Vervis.Handler.Repo , postPostReceiveR + , postRepoLinkR + @@ -70,6 +72,7 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (logWarn) import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Bifunctor import Data.Binary.Put import Data.ByteString (ByteString) @@ -181,6 +184,7 @@ getRepoR repoHash = do (r,) <$> getJust (repoActor r) encodeRouteLocal <- getEncodeRouteLocal + hashLoom <- getEncodeKeyHashid let repoAP = AP.Repo { AP.repoActor = AP.Actor { AP.actorLocal = AP.ActorLocal @@ -206,6 +210,8 @@ getRepoR repoHash = do } , AP.repoTeam = Nothing , AP.repoVcs = repoVcs repo + , AP.repoLoom = + encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo } next = @@ -359,22 +365,31 @@ postGitUploadRequestR repoHash = do getRepoSourceR :: KeyHashid Repo -> [Text] -> Handler Html getRepoSourceR repoHash path = do repoID <- decodeKeyHashid404 repoHash - (repo, actor) <- runDB $ do + (repo, looms, actor) <- runDB $ do r <- get404 repoID - (r,) <$> getJust (repoActor r) + ls <- + case repoLoom r of + Just _ -> pure [] + Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId] + (r,ls,) <$> getJust (repoActor r) + case repoVcs repo of - VCSDarcs -> getDarcsRepoSource repo actor repoHash path + VCSDarcs -> getDarcsRepoSource repo actor repoHash path looms VCSGit -> notFound getRepoBranchSourceR :: KeyHashid Repo -> Text -> [Text] -> Handler Html getRepoBranchSourceR repoHash branch path = do repoID <- decodeKeyHashid404 repoHash - (repo, actor) <- runDB $ do + (repo, looms, actor) <- runDB $ do r <- get404 repoID - (r,) <$> getJust (repoActor r) + ls <- + case repoLoom r of + Just _ -> pure [] + Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId] + (r,ls,) <$> getJust (repoActor r) case repoVcs repo of VCSDarcs -> notFound - VCSGit -> getGitRepoSource repo actor repoHash branch path + VCSGit -> getGitRepoSource repo actor repoHash branch path looms getRepoCommitsR :: KeyHashid Repo -> Handler TypedContent getRepoCommitsR repoHash = do @@ -630,12 +645,62 @@ postPostReceiveR = do |] -} +postRepoLinkR :: KeyHashid Repo -> KeyHashid Loom -> Handler Html +postRepoLinkR repoHash loomHash = do + Entity personID person <- requireAuth + repoID <- decodeKeyHashid404 repoHash + result <- runExceptT $ runDBExcept $ do + repo <- lift $ get404 repoID + unless (isNothing $ repoLoom repo) $ throwE "Repo already has a loom" + loomID <- decodeKeyHashidE loomHash "Invalid loom hash" + loom <- getE loomID "No such loom in DB" + -- Make sure both repo and loom have a single, full-access collab, + -- granted to the logged-in person + maybeApproved <- lift $ runMaybeT $ do + collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] + collabID <- + case collabs of + [Entity _ c] -> return $ collabTopicRepoCollab c + _ -> mzero + CollabRecipLocal _ recipID <- + MaybeT $ getValBy $ UniqueCollabRecipLocal collabID + _ <- MaybeT $ getBy $ UniqueCollabEnable collabID + _ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID + guard $ recipID == personID + collabs' <- lift $ selectList [CollabTopicLoomLoom ==. loomID] [] + collabID' <- + case collabs' of + [Entity _ c] -> return $ collabTopicLoomCollab c + _ -> mzero + CollabRecipLocal _ recipID' <- + MaybeT $ getValBy $ UniqueCollabRecipLocal collabID' + _ <- MaybeT $ getBy $ UniqueCollabEnable collabID' + _ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID' + guard $ recipID' == personID + return () + + unless (isJust maybeApproved) $ + throwE "Repo and loom aren't both yours" + + n <- + lift $ updateWhereCount + [RepoId ==. repoID, RepoLoom ==. Nothing] + [RepoLoom =. Just loomID] + case n of + 0 -> throwE "Couldn't update the repo" + 1 -> return () + _ -> error $ "Unexpected, " ++ show n ++ " repos were updated" + + case result of + Left e -> setMessage $ toHtml e + Right () -> setMessage "Repo successfully linked with loom!" + redirect $ RepoR repoHash diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 337c8fa..a913c29 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2686,6 +2686,8 @@ changes hLocal ctx = , renameUnique "CollabEnable" "UniqueCollabTopicLocalAcceptAccept" "UniqueCollabEnableGrant" -- 492 , removeEntity "CollabTopicLocal" + -- 493 + , addFieldRefOptional "Repo" Nothing "loom" "Loom" ] migrateDB diff --git a/src/Vervis/Web/Darcs.hs b/src/Vervis/Web/Darcs.hs index 835294b..c5933cb 100644 --- a/src/Vervis/Web/Darcs.hs +++ b/src/Vervis/Web/Darcs.hs @@ -82,8 +82,8 @@ import Vervis.Widget.Repo import qualified Vervis.Darcs as D getDarcsRepoSource - :: Repo -> Actor -> KeyHashid Repo -> [Text] -> Handler Html -getDarcsRepoSource repository actor repo dir = do + :: Repo -> Actor -> KeyHashid Repo -> [Text] -> [LoomId] -> Handler Html +getDarcsRepoSource repository actor repo dir loomIDs = do path <- askRepoDir repo msv <- liftIO $ D.readSourceView path dir case msv of @@ -91,7 +91,11 @@ getDarcsRepoSource repository actor repo dir = do Just sv -> do let parent = if null dir then [] else init dir dirs = zip parent (tail $ inits parent) + looms <- runDB $ for loomIDs $ \ loomID -> do + loom <- getJust loomID + (loomID,) <$> getJust (loomActor loom) defaultLayout $ do + hashLoom <- getEncodeKeyHashid host <- asksSite siteInstanceHost ms <- lookupGetParam "style" style <- diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index 88691a6..cba5f8d 100644 --- a/src/Vervis/Web/Git.hs +++ b/src/Vervis/Web/Git.hs @@ -97,8 +97,8 @@ import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Vervis.Git as G getGitRepoSource - :: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> Handler Html -getGitRepoSource repository actor repo ref dir = do + :: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> [LoomId] -> Handler Html +getGitRepoSource repository actor repo ref dir loomIDs = do path <- askRepoDir repo (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir case msv of @@ -106,7 +106,11 @@ getGitRepoSource repository actor repo ref dir = do Just sv -> do let parent = if null dir then [] else init dir dirs = zip parent (tail $ inits parent) + looms <- runDB $ for loomIDs $ \ loomID -> do + loom <- getJust loomID + (loomID,) <$> getJust (loomActor loom) defaultLayout $ do + hashLoom <- getEncodeKeyHashid host <- asksSite siteInstanceHost ms <- lookupGetParam "style" style <- diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b1b044e..6db10ee 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -462,6 +462,7 @@ data Repo u = Repo { repoActor :: Actor u , repoTeam :: Maybe LocalURI , repoVcs :: VersionControlSystem + , repoLoom :: Maybe LocalURI } instance ActivityPub Repo where @@ -474,10 +475,12 @@ instance ActivityPub Repo where Repo a <$> withAuthorityMaybeO h (o .:|? "team") <*> o .: "versionControlSystem" - toSeries authority (Repo actor team vcs) + <*> withAuthorityMaybeO h (o .:? "sendPatchesTo") + toSeries authority (Repo actor team vcs loom) = toSeries authority actor <> "team" .= (ObjURI authority <$> team) <> "versionControlSystem" .= vcs + <> "sendPatchesTo" .=? (ObjURI authority <$> loom) data TicketTracker u = TicketTracker { ticketTrackerActor :: Actor u @@ -1441,6 +1444,7 @@ data CreateObject u | CreateTicket (Authority u) (Ticket u) | CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u)) + | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u)) parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) parseCreateObject o @@ -1457,6 +1461,12 @@ parseCreateObject o vcs <- o .: "versionControlSystem" ml <- parseActorLocal o return $ CreateRepository d vcs ml + <|> do d <- parseActorDetail o + unless (actorType d == ActorTypePatchTracker) $ + fail "type isn't PatchTracker" + repos <- o .:*+ "tracksPatchesFor" + ml <- parseActorLocal o + return $ CreatePatchTracker d repos ml encodeCreateObject :: UriMode u => CreateObject u -> Series encodeCreateObject (CreateNote h note) = toSeries h note @@ -1467,6 +1477,10 @@ encodeCreateObject (CreateRepository d vcs ml) = encodeActorDetail d <> "versionControlSystem" .= vcs <> maybe mempty (uncurry encodeActorLocal) ml +encodeCreateObject (CreatePatchTracker d repos ml) + = encodeActorDetail d + <> "tracksPatchesFor" .=*+ repos + <> maybe mempty (uncurry encodeActorLocal) ml data Create u = Create { createObject :: CreateObject u @@ -1485,6 +1499,7 @@ parseCreate o a luActor = do fail "Create actor != note attrib" CreateTicketTracker _ _ -> return () CreateRepository _ _ _ -> return () + CreatePatchTracker _ _ _ -> return () Create obj <$> o .:? "target" encodeCreate :: UriMode u => Create u -> Series diff --git a/templates/repo/source-darcs.hamlet b/templates/repo/source-darcs.hamlet index 150b4eb..587cfad 100644 --- a/templates/repo/source-darcs.hamlet +++ b/templates/repo/source-darcs.hamlet @@ -50,11 +50,24 @@ $# ^{personNavW user} [🛠 Changes] - - [🧩 Patches] + $maybe loomID <- repoLoom repository + + + [🧩 Patches] ^{followButton} +$if not $ null looms +

Enable patch tracking +