C2S, UI: Loom creation and Repo linking to a Loom

RepoSourceR, for a repo that doesn't have a loom, lists looms that want to
serve that repo with buttons for bidirectionally linking the repo to a loom

Once linked, the repo navbar has a Patches/MRs link pointing to the LoomClothsR
of the linked Loom

src/Data/Aeson/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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)
 

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

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

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|
+            <form method=POST action=@{LoomNewR} enctype=#{enctype}>
+              ^{widget}
+              <div class="submit">
+                  <input type="submit">
+        |]
+
+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"

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

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
 
 
 

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

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
+    :: Repo -> Actor -> KeyHashid Repo -> [Text] -> [LoomId] -> Handler Html
-getDarcsRepoSource repository actor repo dir = do
+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 <-

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
+    :: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> [LoomId] -> Handler Html
-getGitRepoSource repository actor repo ref dir = do
+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 <-

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

templates/repo/source-darcs.hamlet

@@ -50,11 +50,24 @@ $# ^{personNavW user}
   <span>
     <a href=@{RepoCommitsR repo}>
       [🛠 Changes]
-  <span>
+  $maybe loomID <- repoLoom repository
-      [🧩 Patches]
+    <span>
+      <a href=@{LoomClothsR $ hashLoom loomID}>
+        [🧩 Patches]
 
 ^{followButton}
 
+$if not $ null looms
+  <h2>Enable patch tracking
+  <ul>
+    $forall (loomID, actor) <- looms
+      <li>
+        Loom
+        <a href=@{LoomR $ hashLoom loomID}>
+          +#{keyHashidText $ hashLoom loomID} #{actorName actor}
+        wants to link with this repo
+        ^{buttonW POST "Link" $ RepoLinkR repo $ hashLoom loomID}
+
 <h2>Clone
 
 <p>

templates/repo/source-git.hamlet

@@ -50,11 +50,23 @@ $# ^{personNavW user}
   <span>
     <a href=@{RepoCommitsR repo}>
       [🛠 Commits]
-  <span>
+  $maybe loomID <- repoLoom repository
-      [🧩 Merge Requests]
+    <span>
+      <a href=@{LoomClothsR $ hashLoom loomID}>
+        [🧩 Merge Requests]
 
 ^{followButton}
 
+$if not $ null looms
+  <h2>Enable patch tracking
+  <ul>
+    $forall (loomID, actor) <- looms
+      Loom
+      @{LoomR $ hashLoom loomID}
+        +#{keyHashidText $ hashLoom loomID} #{actorName actor}
+      wants to link with this repo
+      ^{buttonW POST "Link" $ RepoLinkR repo $ hashLoom loomID}
+
 <h2>Clone
 
 <p>
@@ -67,16 +79,16 @@ $# ^{personNavW user}
 <h2>Branches
 
 <ul>
-$forall branch <- branches
+  $forall branch <- branches
-  <li>
+    <li>
-    <a href=@{RepoBranchSourceR repo branch []}>#{branch}
+      <a href=@{RepoBranchSourceR repo branch []}>#{branch}
 
 <h2>Tags
 
 <ul>
-$forall tag <- tags
+  $forall tag <- tags
-  <li>
+    <li>
-    <a href=@{RepoBranchSourceR repo tag []}>#{tag}
+      <a href=@{RepoBranchSourceR repo tag []}>#{tag}
 
 <div>
   <a href=@{RepoBranchSourceR repo ref []}>#{ref}

th/models

@@ -347,6 +347,7 @@ Repo
     collabAnon RoleId               Maybe
     actor      ActorId
     create     OutboxItemId
+    loom       LoomId               Maybe
 
     UniqueRepoActor  actor
     UniqueRepoCreate create

th/routes

@@ -180,6 +180,8 @@
 
 /post-receive                                     PostReceiveR       POST
 
+/repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid  RepoLinkR          POST
+
 ---- Deck --------------------------------------------------------------------
 
 /decks/#DeckKeyHashid                             DeckR           GET
@@ -236,11 +238,11 @@
 /looms/#LoomKeyHashid/followers                   LoomFollowersR  GET
 /looms/#LoomKeyHashid/cloths                      LoomClothsR     GET
 
--- /new-loom                                         LoomNewR        GET POST
+/new-loom                                         LoomNewR        GET POST
 -- /looms/#LoomKeyHashid/delete                      LoomDeleteR     POST
 -- /looms/#LoomKeyHashid/edit                        LoomEditR       GET POST
--- /looms/#LoomKeyHashid/follow                      LoomFollowR     POST
+/looms/#LoomKeyHashid/follow                      LoomFollowR     POST
--- /looms/#LoomKeyHashid/unfollow                    LoomUnfollowR   POST
+/looms/#LoomKeyHashid/unfollow                    LoomUnfollowR   POST
 
 ---- Cloth -------------------------------------------------------------------