Implement C2S Create{Ticket}, available in PublishR and in postTicketsR

IMPORTANT: Since a lot of ticket code still doesn't use TicketUnderProject,
creating tickets now appears to be failing. Usage of this patch as is, is at
your own risk ^_^ the next patches will update the ticket handlers to fix this
problem.

config/models

@@ -372,6 +372,13 @@ TicketProjectLocal
     UniqueTicketProjectLocal       ticket
     UniqueTicketProjectLocalAccept accept
 
+TicketProjectRemote
+    ticket  TicketAuthorLocalId
+    tracker RemoteActorId
+    project RemoteObjectId Maybe -- specify if not same as tracker
+
+    UniqueTicketProjectRemote ticket
+
 TicketAuthorLocal
     ticket LocalTicketId
     author PersonId

migrations/2020_02_22_tpr.model

@@ -0,0 +1,6 @@
+TicketProjectRemote
+    ticket  TicketAuthorLocalId
+    tracker RemoteActorId
+    project RemoteObjectId Maybe
+
+    UniqueTicketProjectRemote ticket

src/Vervis/API.hs

@@ -15,6 +15,7 @@
 
 module Vervis.API
     ( createNoteC
+    , createTicketC
     , followC
     , offerTicketC
     , undoC
@@ -398,7 +399,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
         -> OutboxItemId
         -> [ShrIdent]
         -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-        -> ExceptT Text AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> ExceptT Text AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
     deliverLocal pidAuthor obid recips mticket = do
         recipPids <- traverse getPersonId $ nub recips
         when (pidAuthor `elem` recipPids) $
@@ -450,6 +451,272 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
             Right _gid -> throwE "Local Note addresses a local group"
     -}
 
+-- | Handle a Ticket submitted by a local user to their outbox. The ticket's
+-- context project may be local or remote. Return an error message if the
+-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
+createTicketC
+    :: Entity Person
+    -> Sharer
+    -> TextHtml
+    -> Audience URIMode
+    -> AP.Ticket URIMode
+    -> Maybe FedURI
+    -> Handler (Either Text TicketAuthorLocalId)
+createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do
+    let shrUser = sharerIdent sharerUser
+    ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
+    context <- parseTicketContext uContext
+    (localRecips, remoteRecips) <- do
+        mrecips <- parseAudience audience
+        fromMaybeE mrecips "Create Ticket with no recipients"
+    checkFederation remoteRecips
+    verifyProjectRecip context localRecips
+    tracker <- fetchTracker context uTarget
+    now <- liftIO getCurrentTime
+    (talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
+        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
+        project <- prepareProject now tracker
+        talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
+        docCreate <- lift $ insertCreateToOutbox shrUser ticketData now obiidCreate talid
+        remoteRecipsHttpCreate <- do
+            let sieve =
+                    case tracker of
+                        Left (shr, prj) ->
+                            makeRecipientSet
+                                [ LocalActorProject shr prj
+                                ]
+                                [ LocalPersonCollectionSharerFollowers shrUser
+                                , LocalPersonCollectionProjectTeam shr prj
+                                , LocalPersonCollectionProjectFollowers shr prj
+                                ]
+                        Right _ ->
+                            makeRecipientSet
+                                []
+                                [LocalPersonCollectionSharerFollowers shrUser]
+            moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
+            checkFederation moreRemoteRecips
+            lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips
+        maccept <-
+            case project of
+                Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
+                    let prj = projectIdent j
+                        recipsA =
+                            [ LocalActorSharer shrUser
+                            ]
+                        recipsC =
+                            [ LocalPersonCollectionProjectTeam shr prj
+                            , LocalPersonCollectionProjectFollowers shr prj
+                            , LocalPersonCollectionSharerFollowers shrUser
+                            ]
+                    doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
+                    recips <- lift $ deliverLocal' True (LocalActorProject shr prj)  (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
+                    checkFederation recips
+                    lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips
+                Right _ -> return Nothing
+        return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
+    lift $ do
+        forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate
+        for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
+            forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
+    return talid
+    where
+    checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do
+        verifyNothingE mlocal "Ticket with 'id'"
+        encodeRouteLocal <- getEncodeRouteLocal
+        unless (encodeRouteLocal (SharerR shr) == luAttrib) $
+            throwE "Ticket attributed to someone else"
+        verifyNothingE mpublished "Ticket with 'published'"
+        verifyNothingE mupdated "Ticket with 'updated'"
+        context <- fromMaybeE mcontext "Ticket without 'context'"
+        verifyNothingE massigned "Ticket with 'assignedTo'"
+        when resolved $ throwE "Ticket resolved"
+        target <- fromMaybeE mtarget "Create Ticket without 'target'"
+        return (context, summary, content, source, target)
+
+    parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
+    parseTicketContext u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route"
+                case route of
+                    ProjectR shr prj -> return (shr, prj)
+                    _ -> throwE "Ticket context isn't a project route"
+            else return $ Right u
+
+    checkFederation remoteRecips = do
+        federation <- asksSite $ appFederation . appSettings
+        unless (federation || null remoteRecips) $
+            throwE "Federation disabled, but remote recipients found"
+
+    verifyProjectRecip (Right _)         _           = return ()
+    verifyProjectRecip (Left (shr, prj)) localRecips =
+        fromMaybeE verify "Local context project isn't listed as a recipient"
+        where
+        verify = do
+            sharerSet <- lookup shr localRecips
+            projectSet <- lookup prj $ localRecipProjectRelated sharerSet
+            guard $ localRecipProject $ localRecipProjectDirect projectSet
+
+    fetchTracker c u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        case (hl, c) of
+            (True, Left (shr, prj)) -> Left <$> do
+                encodeRouteLocal <- getEncodeRouteLocal
+                unless (encodeRouteLocal (ProjectR shr prj) == lu) $
+                    throwE "Local context and target mismatch"
+                return (shr, prj)
+            (True, Right _) -> throwE "context and target different host"
+            (False, Left _) -> throwE "context and target different host"
+            (False, Right (ObjURI h' lu')) -> Right <$> do
+                unless (h == h') $ throwE "context and target different host"
+                (iid, era) <- do
+                    iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <- lift $ fetchRemoteActor iid h lu
+                    case result of
+                        Left e -> throwE $ T.pack $ displayException e
+                        Right (Left e) -> throwE $ T.pack $ show e
+                        Right (Right mera) -> do
+                            era <- fromMaybeE mera "target found to be a collection, not an actor"
+                            return (iid, era)
+                return (iid, era, if lu == lu' then Nothing else Just lu')
+
+    insertEmptyOutboxItem obid now = do
+        h <- asksSite siteInstanceHost
+        insert OutboxItem
+            { outboxItemOutbox    = obid
+            , outboxItemActivity  = persistJSONObjectFromDoc $ Doc h emptyActivity
+            , outboxItemPublished = now
+            }
+
+    prepareProject now (Left (shr, prj)) = Left <$> do
+        mej <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            MaybeT $ getBy $ UniqueProject prj sid
+        ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
+        obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
+        return (shr, ej, obiidAccept)
+    prepareProject _   (Right (iid, era, mlu)) = lift $ Right <$> do
+        mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
+        return (era, mroid)
+
+    insertTicket now pidUser title desc source obiidCreate project = do
+        did <- insert Discussion
+        fsid <- insert FollowerSet
+        tid <- insert Ticket
+            { ticketNumber      = Nothing
+            , ticketCreated     = now
+            , ticketTitle       = unTextHtml title
+            , ticketSource      = unTextPandocMarkdown source
+            , ticketDescription = unTextHtml desc
+            , ticketAssignee    = Nothing
+            , ticketStatus      = TSNew
+            , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
+            , ticketCloser      = Nothing
+            }
+        ltid <- insert LocalTicket
+            { localTicketTicket    = tid
+            , localTicketDiscuss   = did
+            , localTicketFollowers = fsid
+            }
+        talid <- insert TicketAuthorLocal
+            { ticketAuthorLocalTicket = ltid
+            , ticketAuthorLocalAuthor = pidUser
+            , ticketAuthorLocalOpen   = obiidCreate
+            }
+        case project of
+            Left (_shr, Entity jid _j, obiidAccept) ->
+                insert_ TicketProjectLocal
+                    { ticketProjectLocalTicket  = tid
+                    , ticketProjectLocalProject = jid
+                    , ticketProjectLocalAccept  = obiidAccept
+                    }
+            Right (Entity raid _ra, mroid) ->
+                insert_ TicketProjectRemote
+                    { ticketProjectRemoteTicket  = talid
+                    , ticketProjectRemoteTracker = raid
+                    , ticketProjectRemoteProject = mroid
+                    }
+        return talid
+
+    insertCreateToOutbox shrUser (uContext, title, desc, source, uTarget) now obiidCreate talid = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksSite siteInstanceHost
+        talkhid <- encodeKeyHashid talid
+        obikhid <- encodeKeyHashid obiidCreate
+        let luAttrib = encodeRouteLocal $ SharerR shrUser
+            tlocal = TicketLocal
+                { ticketId           = encodeRouteLocal $ SharerTicketR shrUser talkhid
+                , ticketReplies      = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid
+                , ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid
+                , ticketTeam         = encodeRouteLocal $ SharerTicketTeamR shrUser talkhid
+                , ticketEvents       = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid
+                , ticketDeps         = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
+                , ticketReverseDeps  = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
+                }
+            create = Doc hLocal Activity
+                { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
+                , activityActor    = luAttrib
+                , activitySummary  = Just summary
+                , activityAudience = audience
+                , activitySpecific = CreateActivity Create
+                    { createObject = CreateTicket AP.Ticket
+                        { AP.ticketLocal        = Just (hLocal, tlocal)
+                        , AP.ticketAttributedTo = luAttrib
+                        , AP.ticketPublished    = Just now
+                        , AP.ticketUpdated      = Nothing
+                        , AP.ticketContext      = Just uContext
+                        , AP.ticketSummary      = title
+                        , AP.ticketContent      = desc
+                        , AP.ticketSource       = source
+                        , AP.ticketAssignedTo   = Nothing
+                        , AP.ticketIsResolved   = False
+                        }
+                    , createTarget = Just uTarget
+                    }
+                }
+        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
+        return create
+
+    insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        obikhidCreate <- encodeKeyHashid obiidCreate
+        talkhid <- encodeKeyHashid talid
+        let prjJ = projectIdent j
+        summary <-
+            TextHtml . TL.toStrict . renderHtml <$>
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          Project #
+                          <a href=@{ProjectR shrJ prjJ}>
+                            #{prj2text prjJ}
+                          \ accepted #
+                          <a href=@{SharerTicketR shrU talkhid}>
+                            ticket
+                          \ by #
+                          <a href=@{SharerR shrU}>
+                            #{shr2text shrU}
+                    |]
+        let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
+            accept = Doc hLocal Activity
+                { activityId       = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept
+                , activityActor    = encodeRouteLocal $ ProjectR shrJ prjJ
+                , activitySummary  = Just summary
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate
+                    , acceptResult = Nothing
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
+        return accept
+
+    dont = Authority "dont-do.any-forwarding" Nothing
+
 data Followee
     = FolloweeSharer ShrIdent
     | FolloweeProject ShrIdent PrjIdent
@@ -1041,7 +1308,7 @@ pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
         :: OutboxItemId
         -> AppDB
             [ ( (InstanceId, Host)
-              , NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
+              , NonEmpty RemoteRecipient
               )
             ]
     deliverLocal obiid = do

src/Vervis/ActivityPub.hs

@@ -41,6 +41,8 @@ module Vervis.ActivityPub
     , deliverRemoteHttp
     , serveCommit
     , deliverLocal
+    , RemoteRecipient (..)
+    , deliverLocal'
     )
 where
 
@@ -200,7 +202,7 @@ getPersonOrGroupId sid = do
         "Found sharer that is neither person nor group"
         "Found sharer that is both person and group"
 
-getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
 getTicketTeam sid = do
     id_ <- getPersonOrGroupId sid
     (,[]) <$> case id_ of
@@ -213,7 +215,7 @@ getProjectTeam = getTicketTeam
 
 getRepoTeam = getTicketTeam
 
-getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
 getFollowers fsid = do
     local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
     remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
@@ -239,16 +241,16 @@ getFollowers fsid = do
                 remote
         )
     where
-    groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
     groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
         where
-        toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), (raid, luA, luI, ms))
+        toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), RemoteRecipient raid luA luI ms)
 
 unionRemotes
-    :: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    :: [((InstanceId, Host), NonEmpty RemoteRecipient)]
-    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-unionRemotes = unionGroupsOrdWith fst fst4
+unionRemotes = unionGroupsOrdWith fst remoteRecipientActor
 
 insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
     where
@@ -303,21 +305,21 @@ deliverRemoteDB
     -> RemoteActivityId
     -> ProjectId
     -> ByteString
-    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
     -> AppDB
         [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
 deliverRemoteDB body ractid jid sig recips = do
     let body' = BL.toStrict body
         deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
     fetchedDeliv <- for recips $ \ (i, rs) ->
-        (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
+        (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
     return $ takeNoError4 fetchedDeliv
     where
     takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
     takeNoError4 = takeNoError noError
         where
-        noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
-        noError ((_ , _  , _  , Just _ ), _  ) = Nothing
+        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing
 
 deliverRemoteHTTP
     :: UTCTime
@@ -449,7 +451,7 @@ deliverRemoteDB'
     :: Host
     -> OutboxItemId
     -> [(Host, NonEmpty LocalURI)]
-    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
     -> AppDB
         ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
         , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
@@ -474,7 +476,7 @@ deliverRemoteDB' hContext obid recips known = do
                             Nothing -> Just $ Left lu
                             Just (ro, r) ->
                                 case r of
-                                    RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
+                                    RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
                                     RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
                                     RecipRC _ -> Nothing
                 let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
@@ -486,7 +488,7 @@ deliverRemoteDB' hContext obid recips known = do
         allFetched = unionRemotes known moreKnown
     fetchedDeliv <- for allFetched $ \ (i, rs) ->
         let fwd = snd i == hContext
-        in  (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
+        in  (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
     unfetchedDeliv <- for unfetched $ \ (i, rs) ->
         let fwd = snd i == hContext
         in  (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
@@ -511,8 +513,8 @@ deliverRemoteDB' hContext obid recips known = do
         noError ((_ , _ , Just _ ), _  ) = Nothing
     takeNoError4 = takeNoError noError
         where
-        noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
-        noError ((_ , _  , _  , Just _ ), _  ) = Nothing
+        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing
 
 deliverRemoteHttp
     :: Host
@@ -712,13 +714,12 @@ deliverLocal
     -> LocalRecipientSet
     -> AppDB
         [ ( (InstanceId, Host)
-          , NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
+          , NonEmpty RemoteRecipient
           )
         ]
-deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = fmap (map $ second $ NE.map fromRR) . deliverLocal' True shrAuthor ibidAuthor obiid . localRecipSieve sieve True
+deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True
     where
     sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])]
-    fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince)
 
 data RemoteRecipient = RemoteRecipient
     { remoteRecipientActor      :: RemoteActorId
@@ -735,12 +736,12 @@ data RemoteRecipient = RemoteRecipient
 --   the remote members
 deliverLocal'
     :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-    -> ShrIdent
+    -> LocalActor
     -> InboxId
     -> OutboxItemId
     -> LocalRecipientSet
     -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
+deliverLocal' requireOwner author ibidAuthor obiid recips = do
     ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
     ibidsOther <- concat <$> traverse getOtherInboxes recips
 
@@ -799,7 +800,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
                 [shr | (shr, s) <- sharers
                      , let d = localRecipSharerDirect s
                        in  localRecipSharerFollowers d &&
-                           (localRecipSharer d || not requireOwner || shr == shrAuthor)
+                           (localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
                 ]
         sids <- selectKeysList [SharerIdent <-. shrs] []
         map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
@@ -819,7 +820,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
                     [prj | (prj, j) <- projects
                          , let d = localRecipProjectDirect j
                            in  localRecipProjectFollowers d &&
-                               (localRecipProject d || not requireOwner)
+                               (localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
                     ]
             fsidsJ <-
                 map (projectFollowers . entityVal) <$>
@@ -829,7 +830,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
                         then
                             [ (prj, localRecipTicketRelated j)
                                 | (prj, j) <- projects
-                                , localRecipProject $ localRecipProjectDirect j
+                                , localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
                             ]
                         else
                             map (second localRecipTicketRelated) projects
@@ -863,7 +864,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
                     [rp | (rp, r) <- repos
                         , let d = localRecipRepoDirect r
                           in  localRecipRepoFollowers d &&
-                              (localRecipRepo d || not requireOwner)
+                              (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
                     ]
             in  map (repoFollowers . entityVal) <$>
                     selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
@@ -911,7 +912,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
         getProjectTeams sid projects = do
             let prjs =
                     [prj | (prj, LocalProjectRelatedSet d ts) <- projects
-                         , (localRecipProject d || not requireOwner) &&
+                         , (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
                            (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
                     ]
             jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
@@ -922,7 +923,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
                     [rp | (rp, r) <- repos
                         , let d = localRecipRepoDirect r
                           in  localRecipRepoTeam d &&
-                              (localRecipRepo d || not requireOwner)
+                              (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
                     ]
             rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
             pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []

src/Vervis/ActivityPub/Recipient.hs

@@ -15,6 +15,7 @@
 
 module Vervis.ActivityPub.Recipient
     ( LocalActor (..)
+    , LocalPersonCollection (..)
     , LocalTicketDirectSet (..)
     , LocalProjectDirectSet (..)
     , LocalProjectRelatedSet (..)
@@ -25,6 +26,9 @@ module Vervis.ActivityPub.Recipient
     , LocalRecipientSet
     , concatRecipients
     , parseLocalActor
+    , renderLocalActor
+    , renderLocalPersonCollection
+    , makeRecipientSet
     , parseAudience
     , actorRecips
     , localRecipSieve
@@ -78,6 +82,7 @@ data LocalActor
     = LocalActorSharer ShrIdent
     | LocalActorProject ShrIdent PrjIdent
     | LocalActorRepo ShrIdent RpIdent
+    deriving Eq
 
 parseLocalActor :: Route App -> Maybe LocalActor
 parseLocalActor (SharerR shr)      = Just $ LocalActorSharer shr
@@ -85,6 +90,11 @@ parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj
 parseLocalActor (RepoR shr rp)     = Just $ LocalActorRepo shr rp
 parseLocalActor _                  = Nothing
 
+renderLocalActor :: LocalActor -> Route App
+renderLocalActor (LocalActorSharer shr)      = SharerR shr
+renderLocalActor (LocalActorProject shr prj) = ProjectR shr prj
+renderLocalActor (LocalActorRepo shr rp)     = RepoR shr rp
+
 data LocalPersonCollection
     = LocalPersonCollectionSharerFollowers ShrIdent
     | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
@@ -93,6 +103,7 @@ data LocalPersonCollection
     | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
     | LocalPersonCollectionRepoTeam ShrIdent RpIdent
     | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
+    deriving Eq
 
 parseLocalPersonCollection
     :: Route App -> Maybe LocalPersonCollection
@@ -112,6 +123,15 @@ parseLocalPersonCollection (RepoFollowersR shr rp) =
     Just $ LocalPersonCollectionRepoFollowers shr rp
 parseLocalPersonCollection _ = Nothing
 
+renderLocalPersonCollection :: LocalPersonCollection -> Route App
+renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr)            = SharerFollowersR shr
+renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj)            = ProjectTeamR shr prj
+renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj)       = ProjectFollowersR shr prj
+renderLocalPersonCollection (LocalPersonCollectionTicketTeam shr prj ltkhid)      = TicketTeamR shr prj ltkhid
+renderLocalPersonCollection (LocalPersonCollectionTicketFollowers shr prj ltkhid) = TicketParticipantsR shr prj ltkhid
+renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp)                = RepoTeamR shr rp
+renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp)           = RepoFollowersR shr rp
+
 parseLocalRecipient
     :: Route App -> Maybe (Either LocalActor LocalPersonCollection)
 parseLocalRecipient r =
@@ -321,6 +341,12 @@ groupLocalRecipients
 -- Parse URIs into a grouped recipient set
 -------------------------------------------------------------------------------
 
+makeRecipientSet :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet
+makeRecipientSet actors collections =
+    groupLocalRecipients $
+        map groupedRecipientFromActor actors ++
+        map groupedRecipientFromCollection collections
+
 parseRecipients
     :: (MonadSite m, SiteEnv m ~ App)
     => NonEmpty FedURI

src/Vervis/Client.hs

@@ -22,6 +22,7 @@ module Vervis.Client
     , followTicket
     , followRepo
     , offerTicket
+    , createTicket
     , undoFollowSharer
     , undoFollowProject
     , undoFollowTicket
@@ -233,6 +234,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
             , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
             , AP.ticketPublished    = Nothing
             , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = Nothing
             -- , AP.ticketName         = Nothing
             , AP.ticketSummary      = TextHtml title
             , AP.ticketContent      = TextHtml descHtml
@@ -254,6 +256,66 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
             }
     return (summary, audience, offer)
 
+createTicket
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent
+    -> TextHtml
+    -> TextPandocMarkdown
+    -> FedURI
+    -> FedURI
+    -> m (Either Text (TextHtml, Audience URIMode, Create URIMode))
+createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context = runExceptT $ do
+    summary <-
+        TextHtml . TL.toStrict . renderHtml <$>
+            withUrlRenderer
+                [hamlet|
+                  <p>
+                    <a href=@{SharerR shrAuthor}>
+                      #{shr2text shrAuthor}
+                    \ opened a ticket on project #
+                    <a href="#{renderObjURI context}"}>
+                      #{renderObjURI context}
+                    : #{preEscapedToHtml title}.
+                |]
+
+    encodeRouteHome <- getEncodeRouteHome
+    let recipsA = [target]
+        recipsC =
+            let ObjURI h (LocalURI lu) = context
+            in  [ ObjURI h $ LocalURI $ lu <> "/followers"
+                , ObjURI h $ LocalURI $ lu <> "/team"
+                , encodeRouteHome $ SharerFollowersR shrAuthor
+                ]
+        audience = Audience
+            { audienceTo        = recipsA ++ recipsC
+            , audienceBto       = []
+            , audienceCc        = []
+            , audienceBcc       = []
+            , audienceGeneral   = []
+            , audienceNonActors = recipsC
+            }
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    descHtml <- ExceptT . pure $ renderPandocMarkdown desc
+    let ticket = AP.Ticket
+            { AP.ticketLocal        = Nothing
+            , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
+            , AP.ticketPublished    = Nothing
+            , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = Just context
+            , AP.ticketSummary      = TextHtml title
+            , AP.ticketContent      = TextHtml descHtml
+            , AP.ticketSource       = TextPandocMarkdown desc
+            , AP.ticketAssignedTo   = Nothing
+            , AP.ticketIsResolved   = False
+            }
+        create = Create
+            { createObject = CreateTicket ticket
+            , createTarget = Just target
+            }
+
+    return (summary, audience, create)
+
 undoFollow
     :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
     => ShrIdent

src/Vervis/Federation/Discussion.hs

@@ -347,7 +347,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
         -> SharerId
         -> FollowerSetId
         -> FollowerSetId
-        -> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
     deliverLocal ractid recips sid fsidProject fsidTicket = do
         (teamPids, teamRemotes) <-
             if CreateNoteRecipTicketTeam `elem` recips

src/Vervis/Federation/Offer.hs

@@ -256,7 +256,7 @@ followF
                             newFollow <- insertFollow ractid obiid $ recipFollowers recip
                             if newFollow
                                 then Right <$> do
-                                    let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
+                                    let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
                                         iidAuthor = remoteAuthorInstance author
                                         hAuthor = objUriAuthority $ remoteAuthorURI author
                                         hostSection = ((iidAuthor, hAuthor), raInfo :| [])

src/Vervis/Federation/Ticket.hs

@@ -298,7 +298,7 @@ projectOfferTicketF
         -> [OfferTicketRecipColl]
         -> SharerId
         -> FollowerSetId
-        -> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
     deliverLocal ractid recips sid fsid = do
         (teamPids, teamRemotes) <-
             if OfferTicketRecipProjectTeam `elem` recips
@@ -381,7 +381,7 @@ projectOfferTicketF
             let raidAuthor = remoteAuthorId author
             ra <- getJust raidAuthor
             ro <- getJust $ remoteActorIdent ra
-            let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
+            let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
                 iidAuthor = remoteAuthorInstance author
                 hAuthor = objUriAuthority $ remoteAuthorURI author
                 hostSection = ((iidAuthor, hAuthor), raInfo :| [])

src/Vervis/Form/Ticket.hs

@@ -55,6 +55,7 @@ data NewTicket = NewTicket
     , ntTParams :: [(WorkflowFieldId, Text)]
     , ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
     , ntCParams :: [WorkflowFieldId]
+    , ntOffer   :: Bool
     }
 
 fieldSettings :: Text -> Bool -> FieldSettings App
@@ -135,6 +136,7 @@ newTicketForm wid html = do
         <*> (catMaybes <$> traverse tfield tfs)
         <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
         <*> (catMaybes <$> traverse cfield cfs)
+        <*> areq checkBoxField "Offer" Nothing
 
 editTicketContentAForm :: Ticket -> AForm Handler Ticket
 editTicketContentAForm ticket = Ticket

src/Vervis/Handler/Client.hs

@@ -167,9 +167,23 @@ publishCommentForm html = do
     defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
     defmsg = "Hi! I'm testing federation. Can you see my message? :)"
 
-openTicketForm
+createTicketForm :: Form (FedURI, FedURI, TextHtml, TextPandocMarkdown)
+createTicketForm = renderDivs $ (,,,)
+    <$> areq fedUriField "Tracker" (Just defaultProject)
+    <*> areq fedUriField "Context" (Just defaultProject)
+    <*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
+    <*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
+            areq textareaField "Description" Nothing
+        )
+    where
+    defaultProject =
+        ObjURI
+            (Authority "forge.angeley.es" Nothing)
+            (LocalURI "/s/fr33/p/sandbox")
+
+offerTicketForm
     :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
-openTicketForm html = do
+offerTicketForm html = do
     enc <- getEncodeRouteLocal
     flip renderDivs html $ (,,)
         <$> areq (projectField enc) "Project"     (Just defj)
@@ -195,24 +209,31 @@ activityWidget
     :: Widget -> Enctype
     -> Widget -> Enctype
     -> Widget -> Enctype
+    -> Widget -> Enctype
     -> Widget
-activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3 =
+activityWidget
-    [whamlet|
+    widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
-        <h1>Publish a ticket comment
+        [whamlet|
-        <form method=POST action=@{PublishR} enctype=#{enctype1}>
+            <h1>Publish a ticket comment
-          ^{widget1}
+            <form method=POST action=@{PublishR} enctype=#{enctype1}>
-          <input type=submit>
+              ^{widget1}
+              <input type=submit>
 
-        <h1>Open a new ticket
+            <h1>Open a new ticket (via Create)
-        <form method=POST action=@{PublishR} enctype=#{enctype2}>
+            <form method=POST action=@{PublishR} enctype=#{enctype2}>
-          ^{widget2}
+              ^{widget2}
-          <input type=submit>
+              <input type=submit>
 
-        <h1>Follow a person, a projet or a repo
+            <h1>Open a new ticket (via Offer)
-        <form method=POST action=@{PublishR} enctype=#{enctype3}>
+            <form method=POST action=@{PublishR} enctype=#{enctype3}>
-          ^{widget3}
+              ^{widget3}
-          <input type=submit>
+              <input type=submit>
-    |]
+
+            <h1>Follow a person, a projet or a repo
+            <form method=POST action=@{PublishR} enctype=#{enctype4}>
+              ^{widget4}
+              <input type=submit>
+        |]
 
 getUser :: Handler (ShrIdent, PersonId)
 getUser = do
@@ -228,11 +249,14 @@ getPublishR = do
     ((_result1, widget1), enctype1) <-
         runFormPost $ identifyForm "f1" publishCommentForm
     ((_result2, widget2), enctype2) <-
-        runFormPost $ identifyForm "f2" openTicketForm
+        runFormPost $ identifyForm "f2" createTicketForm
     ((_result3, widget3), enctype3) <-
-        runFormPost $ identifyForm "f3" followForm
+        runFormPost $ identifyForm "f3" offerTicketForm
+    ((_result4, widget4), enctype4) <-
+        runFormPost $ identifyForm "f4" followForm
     defaultLayout $
-        activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3
+        activityWidget
+            widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
 
 postSharerOutboxR :: ShrIdent -> Handler Html
 postSharerOutboxR _shrAuthor = do
@@ -240,8 +264,8 @@ postSharerOutboxR _shrAuthor = do
     unless federation badMethod
 
     error
-        "ActivityPub C2S outbox POST not implemented yet, but you can public \
+        "ActivityPub C2S outbox POST not implemented yet, but you can post \
-        \activities via the /publish page"
+        \public activities via the /publish page"
 
 postPublishR :: Handler Html
 postPublishR = do
@@ -251,15 +275,20 @@ postPublishR = do
     ((result1, widget1), enctype1) <-
         runFormPost $ identifyForm "f1" publishCommentForm
     ((result2, widget2), enctype2) <-
-        runFormPost $ identifyForm "f2" openTicketForm
+        runFormPost $ identifyForm "f2" createTicketForm
     ((result3, widget3), enctype3) <-
-        runFormPost $ identifyForm "f3" followForm
+        runFormPost $ identifyForm "f3" offerTicketForm
+    ((result4, widget4), enctype4) <-
+        runFormPost $ identifyForm "f4" followForm
     let result
-            =   Left <$> result1
+            =   Left . Left <$> result1
-            <|> Right . Left <$> result2
+            <|> Left . Right <$> result2
-            <|> Right . Right <$> result3
+            <|> Right . Left <$> result3
+            <|> Right . Right <$> result4
 
-    shrAuthor <- getUserShrIdent
+    ep@(Entity _ p) <- requireVerifiedAuth
+    s <- runDB $ getJust $ personIdent p
+    let shrAuthor = sharerIdent s
 
     eid <- runExceptT $ do
         input <-
@@ -267,16 +296,21 @@ postPublishR = do
                 FormMissing -> throwE "Field(s) missing"
                 FormFailure _l -> throwE "Invalid input, see below"
                 FormSuccess r -> return r
-        bitraverse (publishComment shrAuthor) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
+        bitraverse (bitraverse (publishComment shrAuthor) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
     case eid of
         Left err -> setMessage $ toHtml err
         Right id_ ->
             case id_ of
-                Left lmid -> do
+                Left (Left lmid) -> do
                     lmkhid <- encodeKeyHashid lmid
                     renderUrl <- getUrlRender
                     let u = renderUrl $ MessageR shrAuthor lmkhid
                     setMessage $ toHtml $ "Message created! ID: " <> u
+                Left (Right talid) -> do
+                    talkhid <- encodeKeyHashid talid
+                    renderUrl <- getUrlRender
+                    let u = renderUrl $ SharerTicketR shrAuthor talkhid
+                    setMessage $ toHtml $ "Ticket created! ID: " <> u
                 Right (Left _obiid) ->
                     setMessage "Ticket offer published!"
                 Right (Right _obiid) ->
@@ -286,6 +320,7 @@ postPublishR = do
             widget1 enctype1
             widget2 enctype2
             widget3 enctype3
+            widget4 enctype4
     where
     publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
         encodeRouteFed <- getEncodeRouteHome
@@ -319,6 +354,15 @@ postPublishR = do
                 , noteContent   = contentHtml
                 }
         ExceptT $ createNoteC hLocal note
+    publishTicket eperson sharer (target, context, title, desc) = do
+        (summary, audience, create) <-
+            ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
+        let ticket =
+                case createObject create of
+                    CreateTicket t -> t
+                    _ -> error "Create object isn't a ticket"
+            target = createTarget create
+        ExceptT $ createTicketC eperson sharer summary audience ticket target
     openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteFed <- getEncodeRouteFed
@@ -664,12 +708,14 @@ postTicketsR shr prj = do
         return $ projectWorkflow j
     ((result, widget), enctype) <- runFormPost $ newTicketForm wid
 
-    shrAuthor <- do
+    (eperson, sharer) <- do
-        Entity _ p <- requireVerifiedAuth
+        ep@(Entity _ p) <- requireVerifiedAuth
-        runDB $ sharerIdent <$> getJust (personIdent p)
+        s <- runDB $ getJust $ personIdent p
+        return (ep, s)
+    let shrAuthor = sharerIdent sharer
 
-    eltid <- runExceptT $ do
+    eid <- runExceptT $ do
-        NewTicket title desc tparams eparams cparams <-
+        NewTicket title desc tparams eparams cparams offer <-
             case result of
                 FormMissing -> throwE "Field(s) missing."
                 FormFailure _l ->
@@ -691,23 +737,38 @@ postTicketsR shr prj = do
                     }
             insertMany_ $ map mkeparam $ ntEParams nt
             -}
-        (summary, audience, offer) <-
+        if offer
-            ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
+            then Right <$> do
-        obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
+                (summary, audience, offer) <-
-        ExceptT $ runDB $ do
+                    ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
-            mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
+                obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
-            return $
+                ExceptT $ runDB $ do
-                case mtal of
+                    mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
-                    Nothing ->
+                    return $
-                        Left
+                        case mtal of
-                            "Offer processed successfully but no ticket \
+                            Nothing ->
-                            \created"
+                                Left
-                    Just tal -> Right $ ticketAuthorLocalTicket tal
+                                    "Offer processed successfully but no ticket \
-    case eltid of
+                                    \created"
+                            Just tal -> Right $ ticketAuthorLocalTicket tal
+            else Left <$> do
+                (summary, audience, Create obj mtarget) <- do
+                    encodeRouteHome <- getEncodeRouteHome
+                    let project = encodeRouteHome $ ProjectR shr prj
+                    ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project
+                let ticket =
+                        case obj of
+                            CreateTicket t -> t
+                            _ -> error "Create object isn't a ticket"
+                ExceptT $ createTicketC eperson sharer summary audience ticket mtarget
+    case eid of
         Left e -> do
             setMessage $ toHtml e
             defaultLayout $(widgetFile "ticket/new")
-        Right ltid -> do
+        Right (Left talid) -> do
+            talkhid <- encodeKeyHashid talid
+            redirect $ SharerTicketR shr talkhid
+        Right (Right ltid) -> do
             ltkhid <- encodeKeyHashid ltid
             eobiidFollow <- runExceptT $ do
                 (summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False

src/Vervis/Migration.hs

@@ -1507,6 +1507,8 @@ changes hLocal ctx =
     , removeField "RemoteMessage" "ident"
       -- 233
     , renameField "RemoteMessage" "identNew" "ident"
+      -- 234
+    , addEntities model_2020_02_22
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -180,6 +180,7 @@ module Vervis.Migration.Model
     , RemoteObject227Generic (..)
     , RemoteMessage227
     , RemoteMessage227Generic (..)
+    , model_2020_02_22
     )
 where
 
@@ -350,3 +351,6 @@ makeEntitiesMigration "223"
 
 makeEntitiesMigration "227"
     $(modelFile "migrations/2020_02_10_rm_point_to_ro.model")
+
+model_2020_02_22 :: [Entity SqlBackend]
+model_2020_02_22 = $(schema "2020_02_22_tpr")