Write S2S Create/Ticket handler for sharer inbox

src/Vervis/Federation.hs

@@ -266,10 +266,12 @@ handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
     case activitySpecific $ actbActivity body of
         AcceptActivity accept ->
             sharerAcceptF shrRecip now author body accept
-        CreateActivity (Create obj _target) ->
+        CreateActivity (Create obj mtarget) ->
             case obj of
                 CreateNote note ->
                     sharerCreateNoteF now shrRecip author body note
+                CreateTicket ticket ->
+                    sharerCreateTicketF now shrRecip author body ticket mtarget
                 _ -> return "Unsupported create object type for sharers"
         FollowActivity follow ->
             sharerFollowF shrRecip now author body follow

src/Vervis/Federation/Ticket.hs

@@ -16,6 +16,8 @@
 module Vervis.Federation.Ticket
     ( sharerOfferTicketF
     , projectOfferTicketF
+
+    , sharerCreateTicketF
     )
 where
 
@@ -24,6 +26,7 @@ import Control.Monad
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Data.Aeson
 import Data.Bifunctor
 import Data.Foldable
@@ -400,3 +403,106 @@ projectOfferTicketF
                 ibiid <- insert $ InboxItem True
                 insert_ $ InboxItemLocal ibid obiid ibiid
             return remotes
+
+sharerCreateTicketF
+    :: UTCTime
+    -> ShrIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> AP.Ticket URIMode
+    -> Maybe FedURI
+    -> ExceptT Text Handler Text
+sharerCreateTicketF now shrRecip author body ticket muTarget = do
+    luCreate <-
+        fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
+    mtarget <- traverse (checkTracker "Create target") muTarget
+    context <- checkTicket ticket
+    targetAndContext <- checkTargetAndContext mtarget context
+    runDBExcept $ do
+        ibidRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            p <- getValBy404 $ UniquePersonIdent sid
+            return $ personInbox p
+        checkTargetAndContextDB targetAndContext
+        lift $ insertToInbox luCreate ibidRecip
+    where
+    checkTracker name u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        (name <> " is local but isn't a valid route")
+                case route of
+                    ProjectR shr prj -> return (shr, prj)
+                    _ ->
+                        throwE $
+                            name <>
+                            " is a valid local route, but isn't a project \
+                            \route"
+            else return $ Right u
+
+    checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary
+                           _content _source muAssigned resolved) = do
+        (hTicket, _tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
+        hl <- hostIsLocal hTicket
+        when hl $ throwE "Remote author claims to create local ticket"
+        unless (hTicket == objUriAuthority (remoteAuthorURI author)) $
+            throwE "Author created ticket hosted elsewhere"
+        unless (attrib == objUriLocal (remoteAuthorURI author)) $
+            throwE "Author created ticket attibuted to someone else"
+        uContext <- fromMaybeE muContext "Ticket without 'context'"
+        context <- checkTracker "Ticket context" uContext
+
+        _ <- fromMaybeE mpublished "Warning: Ticket without 'published'"
+        verifyNothingE mupdated "Warning: Ticket has 'updated'"
+        verifyNothingE muAssigned "Warning: Ticket has 'assignedTo'"
+        when resolved $ throwE "Warning: Ticket is resolved"
+
+        return context
+
+    checkTargetAndContext Nothing context =
+        return $
+            case context of
+                Left (shr, prj) -> Left (False, shr, prj)
+                Right (ObjURI h lu) -> Right (h, Nothing, lu)
+    checkTargetAndContext (Just target) context =
+        case (target, context) of
+            (Left _, Right _) ->
+                throwE "Create target is local but ticket context is remote"
+            (Right _, Left _) ->
+                throwE "Create target is remote but ticket context is local"
+            (Right (ObjURI hTarget luTarget), Right (ObjURI hContext luContext)) ->
+                if hTarget == hContext
+                    then return $ Right (hTarget, Just luTarget, luContext)
+                    else throwE "Create target and ticket context on \
+                                \different remote hosts"
+            (Left (shr, prj), Left (shr', prj')) ->
+                if shr == shr' && prj == prj'
+                    then return $ Left (True, shr, prj)
+                    else throwE "Create target and ticket context are \
+                                \different local projects"
+
+    checkTargetAndContextDB (Left (_, shr, prj)) = do
+        mj <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            MaybeT $ getBy $ UniqueProject prj sid
+        unless (isJust mj) $ throwE "Local context: No such project"
+    checkTargetAndContextDB (Right _) = return ()
+
+    insertToInbox luAct ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+        roid <-
+            either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
+        let jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity roid jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        let recip = shr2text shrRecip
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of /s/" <> recip
+            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip