S2S sharer inbox: Handle Offer{Ticket} yay!

src/Control/Monad/Trans/Except/Local.hs

@@ -15,6 +15,7 @@
 
 module Control.Monad.Trans.Except.Local
     ( fromMaybeE
+    , verifyNothingE
     )
 where
 
@@ -23,3 +24,7 @@ import Control.Monad.Trans.Except
 fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
 fromMaybeE Nothing  t = throwE t
 fromMaybeE (Just x) _ = return x
+
+verifyNothingE :: Monad m => Maybe a -> e -> ExceptT e m ()
+verifyNothingE Nothing  _ = return ()
+verifyNothingE (Just _) e = throwE e

src/Vervis/API.hs

@@ -152,8 +152,8 @@ parseComment luParent = do
 createNoteC :: Text -> Note -> Handler (Either Text LocalMessageId)
 createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
     verifyHostLocal host "Attributed to non-local actor"
-    verifyNothing mluNote "Note specifies an id"
-    verifyNothing mpublished "Note specifies published"
+    verifyNothingE mluNote "Note specifies an id"
+    verifyNothingE mpublished "Note specifies published"
     uContext <- fromMaybeE muContext "Note without context"
     recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
     (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
@@ -230,10 +230,6 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
     lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
     return lmid
     where
-    verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
-    verifyNothing Nothing  _ = return ()
-    verifyNothing (Just _) e = throwE e
-
     nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
     nonEmptyE l e =
         case nonEmpty l of

src/Vervis/Federation.hs

@@ -96,6 +96,7 @@ import Yesod.Persist.Local
 import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.Federation.Discussion
+import Vervis.Federation.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -389,15 +390,6 @@ prependError t a = do
         Left e -> throwE $ t <> ": " <> e
         Right x -> return x
 
-parseProject :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent)
-parseProject luRecip = do
-    route <- case decodeRouteLocal luRecip of
-        Nothing -> throwE "Got Create Note with recipient that isn't a valid route"
-        Just r -> return r
-    case route of
-        ProjectR shr prj -> return (shr, prj)
-        _ -> throwE "Got Create Note with non-project recipient"
-
 parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m Int
 parseTicket project luContext = do
     route <- case decodeRouteLocal luContext of
@@ -454,9 +446,13 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
                             "Activity already exists in inbox of /s/" <> recip
                     Just _ ->
                         return $ "Activity inserted to inbox of /s/" <> recip
-handleSharerInbox now shrRecip (Right iidSender) raw activity =
+handleSharerInbox now shrRecip (Right iidAuthor) raw activity =
     case activitySpecific activity of
-        CreateActivity (Create note) -> sharerCreateNoteRemoteF now shrRecip iidSender raw activity note
+        CreateActivity (Create note) ->
+            sharerCreateNoteRemoteF now shrRecip iidAuthor raw activity note
+        OfferActivity offer ->
+            sharerOfferTicketRemoteF
+                now shrRecip iidAuthor raw (activityId activity) offer
         _ -> return "Unsupported activity type"
 
 handleProjectInbox

src/Vervis/Federation/Ticket.hs

@@ -0,0 +1,125 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Federation.Ticket
+    ( sharerOfferTicketRemoteF
+    )
+where
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Data.Aeson
+import Data.Foldable
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist
+import Yesod.Persist.Core
+
+import Database.Persist.JSON
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.FedURI
+
+import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+
+sharerOfferTicketRemoteF
+    :: UTCTime
+    -> ShrIdent
+    -> InstanceId
+    -> Object
+    -> LocalURI
+    -> Offer
+    -> ExceptT Text Handler Text
+sharerOfferTicketRemoteF
+    now shrRecip iidAuthor raw luOffer (Offer ticket uTarget) = do
+        verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
+        _published <-
+            fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
+        verifyNothingE (ticketName ticket) "Ticket with 'name'"
+        verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
+        when (ticketIsResolved ticket) $ throwE "Ticket resolved"
+        (hProject, shrProject, prjProject) <- parseTarget uTarget
+        unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
+        let checkDep' = checkDep hProject shrProject prjProject
+        deps <- traverse checkDep' $ ticketDependsOn ticket
+        local <- hostIsLocal hProject
+        runDBExcept $ do
+            ibidRecip <- lift $ do
+                sid <- getKeyBy404 $ UniqueSharer shrRecip
+                p <- getValBy404 $ UniquePersonIdent sid
+                return $ personInbox p
+            when local $ checkTargetAndDeps shrProject prjProject deps
+            lift $ insertToInbox ibidRecip
+    where
+    parseTarget u = do
+        let (h, lu) = f2l u
+        (shr, prj) <- parseProject lu
+        return (h, shr, prj)
+        where
+        parseProject lu = do
+            route <- case decodeRouteLocal lu of
+                Nothing -> throwE "Expected project route, got invalid route"
+                Just r -> return r
+            case route of
+                ProjectR shr prj -> return (shr, prj)
+                _ -> throwE "Expected project route, got non-project route"
+    checkDep hProject shrProject prjProject u = do
+        let (h, lu) = f2l u
+        unless (h == hProject) $
+            throwE "Dep belongs to different host"
+        (shrTicket, prjTicket, num) <- parseTicket lu
+        unless (shrTicket == shrProject) $
+            throwE "Dep belongs to different sharer under same host"
+        unless (prjTicket == prjProject) $
+            throwE "Dep belongs to different project under same sharer"
+        return num
+        where
+        parseTicket lu = do
+            route <- case decodeRouteLocal lu of
+                Nothing -> throwE "Expected ticket route, got invalid route"
+                Just r -> return r
+            case route of
+                TicketR shr prj num -> return (shr, prj, num)
+                _ -> throwE "Expected ticket route, got non-ticket route"
+    checkTargetAndDeps shrProject prjProject deps = do
+        msid <- lift $ getKeyBy $ UniqueSharer shrProject
+        sid <- fromMaybeE msid "Offer target: no such local sharer"
+        mjid <- lift $ getKeyBy $ UniqueProject prjProject sid
+        jid <- fromMaybeE mjid "Offer target: no such local project"
+        for_ deps $ \ dep -> do
+            mt <- lift $ getBy $ UniqueTicket jid dep
+            unless (isJust mt) $
+                throwE "Local dep: No such ticket number in DB"
+    insertToInbox ibidRecip = do
+        let jsonObj = PersistJSON raw
+            ract = RemoteActivity iidAuthor luOffer 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

vervis.cabal

@@ -127,6 +127,7 @@ library
                        Vervis.Discussion
                        Vervis.Federation
                        Vervis.Federation.Discussion
+                       Vervis.Federation.Ticket
                        Vervis.Field.Key
                        Vervis.Field.Person
                        Vervis.Field.Project