diff --git a/src/Control/Monad/Trans/Except/Local.hs b/src/Control/Monad/Trans/Except/Local.hs index 465e179..62a8931 100644 --- a/src/Control/Monad/Trans/Except/Local.hs +++ b/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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 5514554..426ad78 100644 --- a/src/Vervis/API.hs +++ b/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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index d9c6254..32f19c0 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs new file mode 100644 index 0000000..74c9a5a --- /dev/null +++ b/src/Vervis/Federation/Ticket.hs @@ -0,0 +1,125 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/vervis.cabal b/vervis.cabal index a72350f..97dc0e6 100644 --- a/vervis.cabal +++ b/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