Federated forge server

[[ 🗃 ^rjQ3E vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Commits]

Clone

HTTPS: git clone https://vervis.peers.community/repos/rjQ3E

SSH: git clone USERNAME@vervis.peers.community:rjQ3E

Branches

Tags

main :: src / Vervis / Actor /

Person.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
 - 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.Actor.Person
    (
    )
where

import Control.Applicative
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Optics.Core
import Yesod.Persist.Core

import qualified Data.Text as T

import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Database.Persist.Local

import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Actor.Common
import Vervis.Actor.Person.Client
import Vervis.Actor2
import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Data.Discussion
import Vervis.Data.Follow
import Vervis.Data.Ticket
import Vervis.FedURI

import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Persist.Follow
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
import Vervis.RemoteActorStore
import Vervis.Ticket

-- Meaning: Someone is offering a ticket or dependency to a tracker
-- Behavior:
--      * Insert to my inbox
personOffer
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Offer URIMode
    -> ActE (Text, Act (), Next)
personOffer now recipPersonID (Verse authorIdMsig body) (AP.Offer object uTarget) = do

    -- Check input
    ticket <-
        case object of
            AP.OfferTicket t -> pure t
            _ -> throwE "Unsupported Offer.object type"
    ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
    WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
    unless (bimap LocalActorPerson id wioAuthor == author) $
        throwE "Offering a Ticket attributed to someone else"

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeOfferDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeOfferDB $ \ (inboxItemID, _offerDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) ->
            doneDB inboxItemID "Inserted this Offer to my inbox"

-- Meaning: Someone has asked to resolve a ticket/MR
-- Behavior:
--      * Insert to my inbox
personResolve
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Resolve URIMode
    -> ActE (Text, Act (), Next)
personResolve now recipPersonID (Verse authorIdMsig body) (AP.Resolve uObject) = do

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeResolveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeResolveDB $ \ (inboxItemID, _resolveDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) ->
            doneDB inboxItemID "Inserted this Resolve to my inbox"

------------------------------------------------------------------------------
-- Following
------------------------------------------------------------------------------

-- Meaning: Someone is following someone
-- Behavior:
--      * Verify I'm the target
--      * Record the follow in DB
--      * Publish and send an Accept to the sender and its followers
personFollow
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Follow URIMode
    -> ActE (Text, Act (), Next)
personFollow now recipPersonID verse follow = do
    recipPersonHash <- encodeKeyHashid recipPersonID
    actorFollow
        (\case
            PersonR p | p == recipPersonHash -> pure ()
            _ -> throwE "Asking to follow someone else"
        )
        personActor
        True
        (\ recipPersonActor () ->
            pure $ actorFollowers recipPersonActor
        )
        (\ () -> pure $ makeRecipientSet [] [])
        LocalActorPerson
        (\ () -> pure [])
        now recipPersonID verse follow

-- Meaning: Someone is undoing some previous action
-- Behavior:
--      * Insert to my inbox
--      * If they're undoing their Following of me:
--          * Record it in my DB
--          * Publish and send an Accept only to the sender
personUndo
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Undo URIMode
    -> ActE (Text, Act (), Next)
personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do

    -- Check input
    undone <-
        first (\ (actor, _, item) -> (actor, item)) <$>
            parseActivityURI' uObject

    maybeUndo <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        -- Insert the Undo to person's inbox
        maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
        for maybeUndoDB $ \ (inboxItemID, undoDB) -> (inboxItemID,) <$> do

            maybeUndo <- runMaybeT $ do

                -- Find the undone activity in our DB
                undoneDB <- MaybeT $ getActivity undone

                let followers = actorFollowers actorRecip
                tryUnfollow followers undoneDB undoDB

            for maybeUndo $ \ () -> do

                -- Prepare an Accept activity and insert to person's outbox
                acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
                accept@(actionAccept, _, _, _) <- lift $ lift prepareAccept
                _luAccept <- lift $ updateOutboxItem' (LocalActorPerson recipPersonID) acceptID actionAccept

                return (personActor personRecip, acceptID, accept)

    case maybeUndo of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Unrelated to me, just inserted to inbox"
                Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
                    lift $ sendActivity
                        (LocalActorPerson recipPersonID) actorID localRecipsAccept
                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
                    doneDB inboxItemID "Undid the Follow and published Accept"

    where

    tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
        Entity remoteFollowID remoteFollow <-
            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
        let followerID = remoteFollowActor remoteFollow
            followerSetID = remoteFollowTarget remoteFollow
        guard $ followerSetID == personFollowersID
        unless (followerID == remoteAuthorId author) $
            lift $ throwE "You're trying to Undo someone else's Follow"
        lift $ lift $ delete remoteFollowID
    tryUnfollow personFollowersID (Left (_, _, outboxItemID)) (Left (_, actorID, _)) = do
        Entity followID follow <-
            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
        let followerID = followActor follow
            followerSetID = followTarget follow
        guard $ followerSetID == personFollowersID
        unless (followerID == actorID) $
            lift $ throwE "You're trying to Undo someone else's Follow"
        lift $ lift $ delete followID
    tryUnfollow _ _ _ = mzero

    prepareAccept = do
        encodeRouteHome <- getEncodeRouteHome

        audSender <- makeAudSenderOnly authorIdMsig
        uUndo <- getActivityURI authorIdMsig
        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audSender]

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Nothing
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = []
                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
                    { AP.acceptObject   = uUndo
                    , AP.acceptResult   = Nothing
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

-- Meaning: An actor accepted something
-- Behavior:
--      * Insert to my inbox
--      * If it's on a Follow I sent to them:
--          * Add to my following list in DB
--      * If it's on an Invite-for-me to collaborate on a resource:
--          * Verify I haven't yet seen the resource's accept
--          * Verify the Accept author is the resource
--          * Store it in the Permit record in DB
--          * Forward to my followers
personAccept
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Accept URIMode
    -> ActE (Text, Act (), Next)
personAccept now recipPersonID (Verse authorIdMsig body) accept = do

    -- Check input
    acceptee <- parseAccept accept

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> fmap (inboxItemID,) $ runMaybeT $ do

            -- Find the accepted activity in our DB
            accepteeDB <- MaybeT $ getActivity acceptee

            let recipActorID = personActor personRecip
            Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
                Right <$> tryInvite recipActorID accepteeDB acceptDB

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox"
                Just (Left ()) ->
                    doneDB inboxItemID "Recorded this Accept on the Follow request I sent"
                Just (Right (actorID, sieve)) -> do
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "Recorded this Accept on the Invite I've had & \
                        \forwarded to my followers"

    where

    tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
        Entity key val <-
            MaybeT $ lift $
                getBy $ UniqueFollowRemoteRequestActivity outboxItemID
        guard $ followRemoteRequestPerson val == recipPersonID
        let uRecip =
                fromMaybe
                    (followRemoteRequestTarget val)
                    (followRemoteRequestRecip val)
        unless (remoteAuthorURI author == uRecip) $
            lift $ throwE "You're Accepting a Follow I sent to someone else"
        lift $ lift $ delete key
        lift $ lift $ insert_ FollowRemote
            { followRemoteActor  = actorID
            , followRemoteRecip  = remoteAuthorId author
            , followRemoteTarget = followRemoteRequestTarget val
            , followRemotePublic = followRemoteRequestPublic val
            , followRemoteFollow = outboxItemID
            , followRemoteAccept = acceptID
            }
    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, acceptID)) = do
        Entity key val <-
            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
        guard $ followRequestActor val == actorID
        targetByKey <-
            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
        unless (authorByKey == targetByKey) $
            lift $ throwE "You're Accepting a Follow I sent to someone else"
        lift $ lift $ delete key
        -- The followee already inserted a Follow, so we just make sure it
        -- already exists
        followKey <- do
            mf <- lift $ lift $ getKeyBy $ UniqueFollowAccept acceptID
            lift $ fromMaybeE mf "Can't find a Follow record in DB"
        mf1 <-
            lift $ lift $ getKeyBy $ UniqueFollow actorID (followRequestTarget val)
        mf2 <-
            lift $ lift $ getKeyBy $ UniqueFollowFollow outboxItemID
        unless (mf1 == Just followKey && mf2 == Just followKey) $
            lift $ throwE "Weird inconsistency with Follow uniques"
        {-
        lift $ lift $ insert_ Follow
            { followActor  = actorID
            , followTarget = followRequestTarget val
            , followPublic = followRequestPublic val
            , followFollow = outboxItemID
            , followAccept = acceptID
            }
        -}
    tryFollow _ (Right _) _ = mzero

    tryInvite recipActorID accepteeDB acceptDB = do

        -- Find a PermitFulfillsInvite
        (permitID, fulfillsID) <-
            case accepteeDB of
                Left (actorByKey, _actorEntity, itemID) -> do
                    PermitTopicGestureLocal fulfillsID _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
                    return (permitID, fulfillsID)
                Right remoteActivityID -> do
                    PermitTopicGestureRemote fulfillsID _ _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
                    return (permitID, fulfillsID)

        -- Find the local person and verify it's me
        Permit p _role <- lift . lift $ getJust permitID
        guard $ p == recipPersonID

        lift $ do
            -- Find the topic
            topic <- lift $ getPermitTopic permitID

            -- Verify I haven't seen the topic's accept yet
            maybeTopicAccept <-
                lift $ case bimap fst fst topic of
                    Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID)
                    Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID)
            unless (isNothing maybeTopicAccept) $
                throwE "I've already seen the topic's Accept"

            -- Verify topic is the Accept sender
            case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of
                (Left la, Left la') | resourceToActor la == la' -> pure ()
                (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                _ -> throwE "Accept sender isn't the Invite topic"

            -- Update the Permit record
            lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB)  of
                (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID
                (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID
                _ -> error "personAccept impossible"

            -- Prepare forwarding Accept to my followers
            recipPersonHash <- encodeKeyHashid recipPersonID
            let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

            return (recipActorID, sieve)

-- Meaning: An actor rejected something
-- Behavior:
--      * Insert to my inbox
--      * If it's a Follow I sent to them, remove record from my DB
personReject
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Reject URIMode
    -> ActE (Text, Act (), Next)
personReject now recipPersonID (Verse authorIdMsig body) reject = do

    -- Check input
    rejectee <- parseReject reject

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeRejectDB $ \ (inboxItemID, _rejectDB) -> fmap (inboxItemID,) $ runMaybeT $ do

            -- Find the rejected activity in our DB
            rejecteeDB <- MaybeT $ getActivity rejectee

            tryFollow (personActor personRecip) rejecteeDB authorIdMsig

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, Nothing) -> doneDB inboxItemID "Not my Follow; Just inserted to my inbox"
        Just (inboxItemID, Just ()) ->
            doneDB inboxItemID "Recorded this Reject on the Follow request I sent"

    where

    tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do
        Entity key val <-
            MaybeT $ lift $
                getBy $ UniqueFollowRemoteRequestActivity outboxItemID
        guard $ followRemoteRequestPerson val == recipPersonID
        let uRecip =
                fromMaybe
                    (followRemoteRequestTarget val)
                    (followRemoteRequestRecip val)
        unless (remoteAuthorURI author == uRecip) $
            lift $ throwE "You're Rejecting a Follow I sent to someone else"
        lift $ lift $ delete key
    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, _)) = do
        Entity key val <-
            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
        guard $ followRequestActor val == actorID
        targetByKey <-
            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
        unless (authorByKey == targetByKey) $
            lift $ throwE "You're Rejecting a Follow I sent to someone else"
        lift $ lift $ delete key
    tryFollow _ (Right _) _ = mzero

------------------------------------------------------------------------------
-- Commenting
------------------------------------------------------------------------------

-- Meaning: Someone commented on an issue/PR
-- Behavior: Insert to inbox
personCreateNote
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Note URIMode
    -> ActE (Text, Act (), Next)
personCreateNote now recipPersonID (Verse authorIdMsig body) note = do

    -- Check input
    (luNote, published, Comment maybeParent topic source content) <- do
        (luId, luAuthor, published, comment) <- parseRemoteComment note
        uCreateAuthor <- lift $ getActorURI authorIdMsig
        unless (luAuthor == objUriLocal uCreateAuthor) $
            throwE "Create author != note author"
        return (luId, published, comment)

    mractid <- withDBExcept $ do
        Entity recipActorID recipActor <- lift $ do
            person <- getJust recipPersonID
            let actorID = personActor person
            Entity actorID <$> getJust actorID

        case topic of

            Right uContext -> do
                checkContextParent uContext maybeParent
                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True

            Left (CommentTopicTicket deckID taskID) -> do
                (_, _, Entity _ ticket, _, _) <- do
                    mticket <- lift $ getTicket deckID taskID
                    fromMaybeE mticket "Context: No such deck-ticket"
                let did = ticketDiscuss ticket
                _ <- traverse (getMessageParent did) maybeParent
                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True

            Left (CommentTopicCloth loomID clothID) -> do
                (_, _, Entity _ ticket, _, _, _) <- do
                    mticket <- lift $ getCloth loomID clothID
                    fromMaybeE mticket "Context: No such loom-cloth"
                let did = ticketDiscuss ticket
                _ <- traverse (getMessageParent did) maybeParent
                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True

    case mractid of
        Nothing -> done "I already have this activity in my inbox, doing nothing"
        Just (inboxItemID, _) -> doneDB inboxItemID "Inserted Create{Note} to my inbox"
    where
    checkContextParent (ObjURI hContext luContext) mparent = do
        mdid <- lift $ runMaybeT $ do
            iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
            rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid
            return $ remoteDiscussionDiscuss rd
        for_ mparent $ \ parent ->
            case parent of
                Left msg -> do
                    did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
                    void $ getLocalParentMessageId did msg
                Right (ObjURI hParent luParent) -> do
                    mrm <- lift $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
                    for_ mrm $ \ rm -> do
                        let mid = remoteMessageRest rm
                        m <- lift $ getJust mid
                        did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
                        unless (messageRoot m == did) $
                            throwE "Remote parent belongs to a different discussion"

------------------------------------------------------------------------------
-- Access
------------------------------------------------------------------------------

-- Meaning: Someone is adding something to something
-- Behavior:
--      * Insert to my inbox
personAdd
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Add URIMode
    -> ActE (Text, Act (), Next)
personAdd now recipPersonID (Verse authorIdMsig body) add = do

    -- Check input
    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
    _ <- parseAdd author add

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeAddDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeAddDB $ \ (inboxItemID, _addDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) -> doneDB inboxItemID "Inserted this Add to my inbox"

-- Meaning: Someone invited someone to a resource
-- Behavior:
--      * Insert to my inbox
--      * If I'm being invited to the resource's collaborators/members
--        collection:
--          * For each Permit record I have for this resource:
--              * Verify it's not enabled yet, i.e. I'm not already a
--                collaborator, haven't received a direct-Grant
--              * Verify it's not in Invite-Accept state, already got the
--                resource's Accept and waiting for my approval or for the
--                topic's Grant
--              * Verify it's not a Join
--          * Create a Permit record in DB
--          * Forward the Invite to my followers
personInvite
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Invite URIMode
    -> ActE (Text, Act (), Next)
personInvite now recipPersonID (Verse authorIdMsig body) invite = do

    -- Check input
    maybeRoleAndResourceDB <- do
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        (role, resource, recip) <- parseInvite author invite
        let recipIsMe =
                case recip of
                    Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True
                    _ -> False
        if not recipIsMe
            then pure Nothing
            else
                -- If resource collabs URI is remote, HTTP GET it and its resource and its
                -- managing actor, and insert to our DB. If resource is local, find it in
                -- our DB.
                case resource of
                    Left r ->
                        case r of
                            Left lr -> withDBExcept $ Just . (role,) . Left <$> getLocalResourceEntityE lr "Invite resource not found in DB"
                            Right _j -> pure Nothing
                    Right u@(ObjURI h luColl) -> do
                        manager <- asksEnv envHttpManager
                        coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                        lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                        if mluCollabs == Just luColl || mluMembers == Just luColl
                            then Just . (role,) . Right <$> do
                                instanceID <-
                                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                                result <-
                                    ExceptT $ first (T.pack . show) <$>
                                        fetchRemoteResource instanceID h lu
                                case result of
                                    Left (Entity actorID actor) ->
                                        return (remoteActorIdent actor, actorID, u)
                                    Right (objectID, luManager, (Entity actorID _)) ->
                                        return (objectID, actorID, ObjURI h luManager)
                            else pure Nothing

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do

            maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do

                -- Find existing Permit records I have for this topic
                -- Make sure none are enabled / in Join mode / in Invite-Accept
                -- mode
                checkExistingPermits
                    recipPersonID
                    (bimap localResourceID (view _2) resourceDB)

                -- Prepare forwarding Invite to my followers
                recipPersonHash <- encodeKeyHashid recipPersonID
                let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

                -- Insert Permit record to DB
                insertPermit resourceDB inviteDB role

                return sieve

            return (personActor personRecip, maybePermit, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (actorID, maybePermit, inboxItemID) ->
            case maybePermit of
                Nothing -> doneDB inboxItemID "I'm not the target; Inserted to inbox"
                Just sieve -> do
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "I'm the target; Inserted to inbox; Inserted Permit; \
                        \Forwarded to followers if addressed"

    where

    insertPermit resourceDB inviteDB role = do
        permitID <- lift $ insert $ Permit recipPersonID role
        case resourceDB of
            Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
            Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
        lift $ do
            fulfillsID <- insert $ PermitFulfillsInvite permitID
            case inviteDB of
                Left (_, _, inviteID) ->
                    insert_ $ PermitTopicGestureLocal fulfillsID inviteID
                Right (author, _, inviteID) ->
                    insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID

-- Meaning: Someone removed someone from a resource
-- Behavior:
--      * Insert to my inbox
--      * If I'm the object, forward the Remove to my followers
personRemove
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Remove URIMode
    -> ActE (Text, Act (), Next)
personRemove now recipPersonID (Verse authorIdMsig body) remove = do

    -- Check input
    memberOrComp <- do
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        (_resource, member) <- parseRemove author remove
        return member

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeRemoveDB $ \ (inboxItemID, _removeDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (actorID, inboxItemID) -> do
            let memberIsMe =
                    case memberOrComp of
                        Left (LocalActorPerson p) -> p == recipPersonID
                        _ -> False
            if not memberIsMe
                then doneDB inboxItemID "I'm not the member; Inserted to inbox"
                else do
                    recipHash <- encodeKeyHashid recipPersonID
                    let sieve =
                            makeRecipientSet
                                []
                                [LocalStagePersonFollowers recipHash]
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "I'm the member; Inserted to inbox; \
                        \Forwarded to followers if addressed"

-- Meaning: Someone asked to join a resource
-- Behavior: Insert to my inbox
personJoin
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Join URIMode
    -> ActE (Text, Act (), Next)
personJoin now recipPersonID (Verse authorIdMsig body) join = do

    -- Check input
    (_role, _resource) <- parseJoin join

    maybeJoinID <- lift $ withDB $ do

        -- Grab me from DB
        (_personRecip, actorRecip) <- do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        insertToInbox now authorIdMsig body (actorInbox actorRecip) True

    case maybeJoinID of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, _joinID) -> doneDB inboxItemID "Inserted to my inbox"

-- Meaning: An actor published a Grant
-- Behavior:
--      * Insert to my inbox
--
--      * If it's a direct-Grant that fulfills a Permit I have:
--          * Verify the Permit isn't already enabled
--          * Verify the sender is the Permit topic
--          * Verify the role is identical to what was requested
--          * Update the Permit record, storing the direct-Grant
--          * Forward the direct-Grant to my followers
--          * If topic is a Project or a Team:
--              * Send a delegator-Grant to the topic
--              * Update the Permit record, storing the delegator-Grant
--
--      * If it's a extension-Grant whose capability is a delegator-Grant from
--        a Permit I have:
--          * Verify the sender is the Permit topic
--          * Update the Permit record, storing the extension-Grant
personGrant
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Grant URIMode
    -> ActE (Text, Act (), Next)
personGrant now recipPersonID (Verse authorIdMsig body) grant = do

    -- Check input
    maybeMine <- do
        -- Verify the capability URI, if provided, is one of:
        --   * Outbox item URI of a local actor, i.e. a local activity
        --   * A remote URI
        maybeCapability <-
            for (AP.activityCapability $ actbActivity body) $ \ uCap ->
                nameExceptT "Grant.capability" $
                    first (\ (actor, _, item) -> (actor, item)) <$>
                        parseActivityURI' uCap

        -- Basic sanity checks
        (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
            parseGrant' grant
        case (recip, authorIdMsig) of
            (Left (LocalActorPerson p), Left (LocalActorPerson p', _, _))
                | p == p' ->
                    throwE "Grant sender and target are the same local Person"
            (Right uRecip, Right (author, _, _))
                | uRecip == remoteAuthorURI author ->
                    throwE "Grant sender and target are the same remote actor"
            _ -> pure ()
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        case mdeleg of
            Nothing ->
                unless (author == resource) $
                    throwE "Not an extension but resource and actor differ"
            Just _ ->
                when (author == resource) $
                    throwE "Extension but resource and actor are identical"

        -- For a direct-Grant, use 'fulfills' to identify the Permit
        -- For an extension-Grant, use 'capability' for that
        runMaybeT $ do
            guard $ usage == AP.Invoke
            guard $ recip == Left (LocalActorPerson recipPersonID)
            lift $ do
                for_ mstart $ \ start ->
                    unless (start <= now) $
                        throwE "Got a Grant that hasn't started"
                for_ mend $ \ _ -> throwE "Got a Grant with expiration"
            if isNothing mdeleg
                then do
                    uFulfills <-
                        case AP.activityFulfills $ actbActivity body of
                            [] -> mzero
                            [u] -> pure u
                            _ -> lift $ throwE "Multiple fulfills"
                    fulfills <-
                        lift $
                        first (\ (actor, _, item) -> (actor, item)) <$>
                            parseActivityURI' uFulfills
                    return $ Left (role, fulfills)
                else do
                    cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability"
                    delegatorID <-
                        case cap of
                            Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
                            _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
                    return $ Right (resource, role, delegatorID)

    -- For extension-Grant, get the resource by DB/HTTP, and check role
    maybeMine' <-
        for maybeMine $ traverseOf _Right $ \ (resource, roleExt, delegatorID) -> do
            role <-
                case roleExt of
                    AP.RXRole r -> pure r
                    AP.RXDelegator -> throwE "I've been delegated a Grant with role being delegate"
            resourceDB <- bitraverse
                (\ la -> do
                    lr <- fromMaybeE (actorToResource la) "Got an extension-Grant with resource being a local Person"
                    withDBExcept $ localResourceID <$>
                        getLocalResourceEntityE lr "Extension-Grant resource not found in DB"
                )
                (\ (ObjURI h lu) -> do
                    manager <- asksEnv envHttpManager
                    instanceID <-
                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                    result <-
                        ExceptT $ first (T.pack . displayException) <$>
                            fetchRemoteActor' instanceID h lu
                    case result of
                        Left Nothing -> throwE "Resource @id mismatch"
                        Left (Just err) -> throwE $ T.pack $ displayException err
                        Right Nothing -> throwE "Resource isn't an actor"
                        Right (Just actor) -> return $ entityKey actor
                )
                resource
            return (resourceDB, role, delegatorID)

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybePermit <-
            for maybeMine' $
                bitraverse
                    (\ (role, fulfills) -> do

                        -- Find my Permit record, verify the roles match
                        fulfillsDB <- do
                            a <- getActivity fulfills
                            fromMaybeE a "Can't find fulfills in DB"
                        (permitID, maybeGestureID) <- do
                            mp <- runMaybeT $ do
                                x@(pt, mg) <-
                                    tryInvite fulfillsDB <|>
                                    tryJoin fulfillsDB <|>
                                    tryCreate fulfillsDB
                                Permit p role' <- lift . lift $ getJust pt
                                guard $ p == recipPersonID
                                lift $ unless (role == AP.RXRole role') $
                                    throwE "Requested and granted roles differ"
                                return x
                            fromMaybeE mp "Can't find a PermitFulfills*"

                        -- If Permit fulfills an Invite, verify I've approved
                        -- it
                        gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"

                        -- Verify the Permit isn't already enabled
                        topic <- lift $ getPermitTopic permitID
                        maybeTopicEnable <-
                            lift $ case bimap fst fst topic of
                                Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
                                Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
                        unless (isNothing maybeTopicEnable) $
                            throwE "I've already received the direct-Grant"

                        -- Verify the Grant sender is the Permit topic
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Grant sender isn't the Permit topic"

                        return (gestureID, bimap fst fst topic)
                    )
                    (\ (resourceDB, role, delegatorID) -> do
                        Entity sendID (PermitPersonSendDelegator gestureID _) <- do
                            mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
                            fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
                        PermitPersonGesture permitID _ <- lift $ getJust gestureID

                        -- Verify the Grant sender is the Permit topic
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Grant sender isn't the Permit topic"

                        return (resourceDB, role, sendID, bimap fst fst topic)
                    )

        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for mractid $ \ (inboxItemID, grantDB) ->

            fmap (inboxItemID,) $
            for maybePermit $
                bitraverse
                    (\ (gestureID, topic) -> lift $ do

                        -- Update the Permit record, storing the direct-Grant
                        case (topic, grantDB) of
                            (Left localID, Left (_, _, grantID)) ->
                                insert_ $ PermitTopicEnableLocal gestureID localID grantID
                            (Right remoteID, Right (_, _, grantID)) ->
                                insert_ $ PermitTopicEnableRemote gestureID remoteID grantID
                            _ -> error "personGrant impossible"

                        -- Prepare forwarding direct-Grant to my followers
                        recipPersonHash <- encodeKeyHashid recipPersonID
                        let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

                         -- Prepapre delegator-Grant and update Permit
                        needDeleg <-
                            case grantDB of
                                Left (la, _, _) ->
                                    pure $ case la of
                                        LocalActorProject _ -> True
                                        LocalActorGroup _ -> True
                                        _ -> False
                                Right (author, _, _) -> do
                                    ra <- getJust $ remoteAuthorId author
                                    pure $ case remoteActorType ra of
                                        AP.ActorTypeProject -> True
                                        AP.ActorTypeTeam -> True
                                        _ -> False
                        maybeDeleg <-
                            if needDeleg
                                then Just <$> do
                                    delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
                                    deleg@(actionDeleg, _, _, _) <- prepareDelegGrant
                                    let recipByKey = LocalActorPerson recipPersonID
                                    _luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg

                                    insert_ $ PermitPersonSendDelegator gestureID delegID

                                    return (delegID, deleg)
                                else
                                    pure Nothing

                        return (personActor personRecip, sieve, maybeDeleg)
                    )
                    (\ (resourceDB, role, sendID, topic) -> do
                        extendID <- case (topic, grantDB) of
                            (Left localID, Left (_, _, extID)) -> lift $ do
                                enableID <- do
                                    me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
                                    case me of
                                        Just e -> pure e
                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
                                extendID <- insert $ PermitTopicExtend sendID role
                                insert_ $ PermitTopicExtendLocal extendID enableID extID
                                return extendID
                            (Right remoteID, Right (_, _, extID)) -> lift $ do
                                enableID <- do
                                    me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
                                    case me of
                                        Just e -> pure e
                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
                                extendID <- insert $ PermitTopicExtend sendID role
                                insert_ $ PermitTopicExtendRemote extendID enableID extID
                                return extendID
                            _ -> error "personGrant impossible 2"
                        lift $ case resourceDB of
                            Left resourceID -> insert_ $ PermitTopicExtendResourceLocal extendID resourceID
                            Right actorID -> insert_ $ PermitTopicExtendResourceRemote extendID actorID
                    )

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Inserted Grant to my inbox"
                Just (Left (recipActorID, sieve, maybeDeleg)) -> do
                    let recipByID = LocalActorPerson recipPersonID
                    forwardActivity authorIdMsig body recipByID recipActorID sieve
                    lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) ->
                        sendActivity
                            recipByID recipActorID localRecipsDeleg
                            remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
                    doneDB inboxItemID "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant"
                Just (Right ()) ->
                    doneDB inboxItemID "Got an extension-Grant, updated Permit"

    where

    tryInvite fulfillsDB = do
        fulfillsID <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) -> do
                    PermitTopicGestureLocal fulfillsID _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
                    return fulfillsID
                Right remoteActivityID -> do
                    PermitTopicGestureRemote fulfillsID _ _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
                    return fulfillsID
        PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
        maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID
        return (permitID, maybeGestureID)

    tryJoin fulfillsDB = do
        Entity gestureID (PermitPersonGesture permitID _) <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) ->
                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
                Right _remoteActivityID -> mzero
        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID
        return (permitID, Just gestureID)

    tryCreate fulfillsDB = do
        Entity gestureID (PermitPersonGesture permitID _) <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) ->
                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
                Right _remoteActivityID -> mzero
        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
        return (permitID, Just gestureID)

    prepareDelegGrant = do
        encodeRouteHome <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal

        personHash <- encodeKeyHashid recipPersonID
        audTopic <- lift $ makeAudSenderOnly authorIdMsig
        uTopic <- lift $ getActorURI authorIdMsig
        uDirectGrant <- lift $ getActivityURI authorIdMsig

        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audTopic]

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Just uDirectGrant
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = [uDirectGrant]
                , AP.actionSpecific   = AP.GrantActivity AP.Grant
                    { AP.grantObject    = AP.RXDelegator
                    , AP.grantContext   = encodeRouteHome $ PersonR personHash
                    , AP.grantTarget    = uTopic
                    , AP.grantResult    = Nothing
                    , AP.grantStart     = Just now
                    , AP.grantEnd       = Nothing
                    , AP.grantAllows    = AP.Invoke
                    , AP.grantDelegates = Nothing
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

-- Meaning: An actor has revoked some previously published Grants
-- Behavior:
--  * Insert to my inbox
--  * For each revoked activity:
--      * If it's a direct-Grant given to me:
--          * Verify the sender is the Permit topic
--          * Delete the Permit record
--      * If it's an extension-Grant given to me:
--          * Verify the sender is the Permit topic
--          * Delete the PermitTopicExtend* record
personRevoke
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Revoke URIMode
    -> ActE (Text, Act (), Next)
personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do

    -- Check input
    grants <- nameExceptT "Revoke.object" $ do
        ObjURI h _ <- lift $ getActorURI authorIdMsig
        hl <- hostIsLocal h
        if hl
            then
                for lus $ \ lu ->
                    (\ (actor, _, item) -> Left (actor, item)) <$>
                        parseLocalActivityURI' lu
            else
                pure $ Right . ObjURI h <$> lus

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        -- Look for the revoked Grants in my Permit records
        grantsDB <- for grants $ \ grant -> runMaybeT $ do
            grantDB <- MaybeT $ getActivity grant
            found <-
                Left <$> tryDirect grantDB <|>
                Right <$> tryExtension grantDB
            bitraverse
                (\ (gestureID, topicAndEnable) -> do

                    -- Verify the Permit is mine
                    PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
                    Permit p _ <- lift . lift $ getJust permitID
                    guard $ p == recipPersonID

                    -- Verify the Revoke sender is the Permit topic
                    lift $ do
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Revoke sender isn't the Permit topic"

                    -- Return data for Permit deletion
                    return (permitID, gestureID, topicAndEnable)
                )
                (\ extend -> do

                    -- Verify the Permit is mine
                    extendID <-
                        lift . lift $ case extend of
                            Left k -> permitTopicExtendLocalPermit <$> getJust k
                            Right k -> permitTopicExtendRemotePermit <$> getJust k
                    PermitTopicExtend sendID _ <- lift . lift $ getJust extendID
                    PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID
                    PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
                    Permit p _ <- lift . lift $ getJust permitID
                    guard $ p == recipPersonID

                    -- Verify the Revoke sender is the Permit topic
                    lift $ do
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Revoke sender isn't the Permit topic"

                    -- Return data for PermitTopicExtend* deletion
                    return (extendID, extend)
                )
                found

        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        lift $ for mractid $ \ (inboxItemID, _revokeDB) -> fmap (inboxItemID,) $
            -- Delete revoked records from DB
            for grantsDB $ traverse_ $
                bitraverse_
                    (\ (permitID, gestureID, topicAndEnable) -> do
                        case topicAndEnable of
                            Left (_, enableID) -> do
                                extends <- selectList [PermitTopicExtendLocalTopic ==. enableID] []
                                let extendIDs = map (permitTopicExtendLocalPermit . entityVal) extends
                                    extendLocalIDs = map entityKey extends
                                deleteWhere [PermitTopicExtendLocalId <-. extendLocalIDs]
                                deleteWhere [PermitTopicExtendResourceLocalPermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendResourceRemotePermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendId <-. extendIDs]
                            Right (_, enableID) -> do
                                extends <- selectList [PermitTopicExtendRemoteTopic ==. enableID] []
                                let extendIDs = map (permitTopicExtendRemotePermit . entityVal) extends
                                    extendRemoteIDs = map entityKey extends
                                deleteWhere [PermitTopicExtendRemoteId <-. extendRemoteIDs]
                                deleteWhere [PermitTopicExtendResourceLocalPermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendResourceRemotePermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendId <-. extendIDs]
                        deleteBy $ UniquePermitPersonSendDelegator gestureID
                        case topicAndEnable of
                            Left (topicID, enableID) -> do
                                delete enableID
                                deleteBy $ UniquePermitTopicAcceptLocalTopic topicID
                            Right (topicID, enableID) -> do
                                delete enableID
                                deleteBy $ UniquePermitTopicAcceptRemoteTopic topicID
                        maybeInvite <- getKeyBy $ UniquePermitFulfillsInvite permitID
                        for_ maybeInvite $ \ inviteID -> do
                            deleteBy $ UniquePermitTopicGestureLocal inviteID
                            deleteBy $ UniquePermitTopicGestureRemote inviteID
                        delete gestureID
                        deleteBy $ UniquePermitFulfillsTopicCreation permitID
                        deleteBy $ UniquePermitFulfillsInvite permitID
                        deleteBy $ UniquePermitFulfillsJoin permitID
                        case topicAndEnable of
                            Left (topicID, _) -> delete topicID
                            Right (topicID, _) -> delete topicID
                        delete permitID
                    )
                    (\ (extendID, extend) -> do
                        case extend of
                            Left k -> delete k
                            Right k -> delete k
                        deleteBy $ UniquePermitTopicExtendResourceLocal extendID
                        deleteBy $ UniquePermitTopicExtendResourceRemote extendID
                        delete extendID
                    )

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, _) -> doneDB inboxItemID "Deleted any relevant Permit/Extend records"

    where

    tryDirect objectDB =
        case objectDB of
            Left (_actorByKey, _actorEntity, itemID) -> do
                Entity enableID (PermitTopicEnableLocal gestureID topicID _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicEnableLocalGrant itemID
                return (gestureID, Left (topicID, enableID))
            Right remoteActivityID -> do
                Entity enableID (PermitTopicEnableRemote gestureID topicID _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicEnableRemoteGrant remoteActivityID
                return (gestureID, Right (topicID, enableID))

    tryExtension objectDB =
        case objectDB of
            Left (_actorByKey, _actorEntity, itemID) -> do
                Entity extendID (PermitTopicExtendLocal _ _ _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicExtendLocalGrant itemID
                return $ Left extendID
            Right remoteActivityID -> do
                Entity extendID (PermitTopicExtendRemote _ _ _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicExtendRemoteGrant remoteActivityID
                return $ Right extendID

------------------------------------------------------------------------------
-- Main behavior function
------------------------------------------------------------------------------

personBehavior :: UTCTime -> PersonId -> VerseExt -> ActE (Text, Act (), Next)
personBehavior now personID (Left verse@(Verse _authorIdMsig body)) =
    case AP.activitySpecific $ actbActivity body of
        AP.AcceptActivity accept -> personAccept now personID verse accept
        AP.AddActivity add -> personAdd now personID verse add
        AP.CreateActivity (AP.Create obj mtarget) ->
            case obj of
                AP.CreateNote _ note ->
                    personCreateNote now personID verse note
                _ -> throwE "Unsupported create object type for people"
        AP.FollowActivity follow -> personFollow now personID verse follow
        AP.GrantActivity grant   -> personGrant now personID verse grant
        AP.InviteActivity invite -> personInvite now personID verse invite
        AP.JoinActivity join     -> personJoin now personID verse join
        AP.OfferActivity offer   -> personOffer now personID verse offer
        AP.RejectActivity reject -> personReject now personID verse reject
        AP.RemoveActivity remove -> personRemove now personID verse remove
        AP.ResolveActivity resolve -> personResolve now personID verse resolve
        AP.RevokeActivity revoke -> personRevoke now personID verse revoke
        AP.UndoActivity undo     -> personUndo now personID verse undo
        _ -> throwE "Unsupported activity type for Person"
personBehavior now personID (Right msg) = clientBehavior now personID msg

instance VervisActor Person where
    actorBehavior now personID ve = do
        errboxID <- lift $ withDB $ do
            actorID <- personActor <$> getJust personID
            actorErrbox <$> getJust actorID
        adaptErrbox errboxID True personBehavior now personID ve
[See repo JSON]