Implement GETing the personal inbox

config/models

@@ -44,11 +44,15 @@ OutboxItem
     activity  PersistActivity
     published UTCTime
 
+InboxItem
+
 InboxItemLocal
     person   PersonId
     activity OutboxItemId
+    item     InboxItemId
 
     UniqueInboxItemLocal person activity
+    UniqueInboxItemLocalItem item
 
 RemoteActivity
     instance InstanceId
@@ -61,8 +65,10 @@ RemoteActivity
 InboxItemRemote
     person   PersonId
     activity RemoteActivityId
+    item     InboxItemId
 
     UniqueInboxItemRemote person activity
+    UniqueInboxItemRemoteItem item
 
 UnlinkedDelivery
     recipient  UnfetchedRemoteActorId

src/Vervis/Federation.hs

@@ -605,12 +605,17 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
             throwE "Activity author in DB and in received JSON don't match"
         if pidRecip == pidAuthor
             then return "Received activity authored by self, ignoring"
-            else do
+            else lift $ do
-                miblid <- lift $ insertUnique $ InboxItemLocal pidRecip obid
+                ibid <- insert InboxItem
+                miblid <- insertUnique $ InboxItemLocal pidRecip obid ibid
                 let recip = shr2text shrRecip
-                return $ case miblid of
+                case miblid of
-                    Nothing -> "Activity already exists in inbox of /s/" <> recip
+                    Nothing -> do
-                    Just _ -> "Activity inserted to inbox of /s/" <> recip
+                        delete ibid
+                        return $
+                            "Activity already exists in inbox of /s/" <> recip
+                    Just _ ->
+                        return $ "Activity inserted to inbox of /s/" <> recip
 handleSharerInbox now shrRecip (Right iidSender) raw activity =
     case activitySpecific activity of
         CreateActivity (Create note) -> handleNote note
@@ -684,11 +689,14 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity =
                 jsonObj = PersistJSON raw
                 ract = RemoteActivity iidSender luActivity jsonObj now
             ractid <- either entityKey id <$> insertBy' ract
-            mibrid <- insertUnique $ InboxItemRemote pidRecip ractid
+            ibid <- insert InboxItem
+            mibrid <- insertUnique $ InboxItemRemote pidRecip ractid ibid
             let recip = shr2text shrRecip
-            return $ case mibrid of
+            case mibrid of
-                Nothing -> "Activity already exists in inbox of /s/" <> recip
+                Nothing -> do
-                Just _ -> "Activity inserted to inbox of /s/" <> recip
+                    delete ibid
+                    return $ "Activity already exists in inbox of /s/" <> recip
+                Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
 
 handleProjectInbox
     :: UTCTime
@@ -889,7 +897,11 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
             let pids = union teamPids fsPids
                 -- TODO inefficient, see the other TODOs about mergeConcat
                 remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
-            for_ pids $ \ pid -> insertUnique_ $ InboxItemRemote pid ractid
+            for_ pids $ \ pid -> do
+                ibid <- insert InboxItem
+                mibrid <- insertUnique $ InboxItemRemote pid ractid ibid
+                when (isNothing mibrid) $
+                    delete ibid
             return remotes
 
         deliverRemoteDB
@@ -1428,7 +1440,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                           -- lists have the same instance.
                         , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
                         )
-        lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
+        lift $ for_ (union recipPids morePids) $ \ pid -> do
+            ibid <- insert InboxItem
+            insert_ $ InboxItemLocal pid obid ibid
         return remotes
         where
         getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId

src/Vervis/Foundation.hs

@@ -235,6 +235,7 @@ instance Yesod App where
             | a == resendVerifyR           -> personFromResendForm
         (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
 
+        (SharerInboxR shr          , False) -> person shr
         (OutboxR shr               , True) -> person shr
 
         (GroupsR                   , True) -> personAny

src/Vervis/Handler/Inbox.hs

@@ -42,6 +42,7 @@ import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
 import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
 import Data.Aeson
+import Data.Aeson.Encode.Pretty
 import Data.Bifunctor (first, second)
 import Data.Foldable (for_)
 import Data.HashMap.Strict (HashMap)
@@ -55,7 +56,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Interval (TimeInterval, toTimeUnit)
 import Data.Time.Units (Second)
-import Database.Persist (Entity (..), getBy, insertBy, insert_)
+import Database.Persist
 import Network.HTTP.Client (Manager, HttpException, requestFromURI)
 import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
 import Network.HTTP.Types.Header (hDate, hHost)
@@ -71,14 +72,16 @@ import Yesod.Core.Handler
 import Yesod.Form.Fields (Textarea (..), textField, textareaField)
 import Yesod.Form.Functions
 import Yesod.Form.Types
-import Yesod.Persist.Core (runDB, get404)
+import Yesod.Persist.Core
 
 import qualified Data.ByteString.Char8 as BC (unpack)
 import qualified Data.CaseInsensitive as CI (mk)
 import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
 import qualified Data.Text as T (pack, unpack, concat)
 import qualified Data.Text.Lazy as TL (toStrict)
+import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Vector as V
+import qualified Database.Esqueleto as E
 import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
 
 import Network.HTTP.Signature hiding (Algorithm (..))
@@ -86,20 +89,25 @@ import Yesod.HttpSignature (verifyRequestSignature)
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
-import Data.Aeson.Encode.Pretty
+import Database.Persist.JSON
-import Data.Aeson.Local
-import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
 
+import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
+
+import Data.Aeson.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
 import Vervis.ActorKey
 import Vervis.Federation
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Paginate
 import Vervis.RemoteActorStore
 import Vervis.Settings
 
@@ -129,7 +137,50 @@ getInboxR = do
         |]
 
 getSharerInboxR :: ShrIdent -> Handler TypedContent
-getSharerInboxR _ = error "TODO implement getSharerInboxR"
+getSharerInboxR shr = do
+    (items, navModel) <- getPageAndNav $ \ off lim -> runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        pid <- getKeyBy404 $ UniquePersonIdent sid
+        (,) <$> countItems pid
+            <*> (map adaptItem <$> getItems pid off lim)
+    let pageNav = navWidget navModel
+    selectRep $ provideRep $ defaultLayout $(widgetFile "person/inbox")
+    where
+    countItems pid =
+        (+) <$> count [InboxItemLocalPerson ==. pid]
+            <*> count [InboxItemRemotePerson ==. pid]
+    getItems pid off lim =
+        E.select $ E.from $
+            \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
+                E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
+                E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
+                E.where_
+                    $ ( E.isNothing (ibr E.?. InboxItemRemotePerson) E.||.
+                        ibr E.?. InboxItemRemotePerson E.==. E.just (E.val pid)
+                      )
+                    E.&&.
+                      ( E.isNothing (ibl E.?. InboxItemLocalPerson) E.||.
+                        ibl E.?. InboxItemLocalPerson E.==. E.just (E.val pid)
+                      )
+                E.orderBy [E.desc $ ib E.^. InboxItemId]
+                E.offset $ fromIntegral off
+                E.limit $ fromIntegral lim
+                return
+                    ( ib E.^. InboxItemId
+                    , ob E.?. OutboxItemActivity
+                    , ract E.?. RemoteActivityContent
+                    )
+    adaptItem (E.Value ibid, E.Value mact, E.Value mobj) =
+        case (mact, mobj) of
+            (Nothing, Nothing) ->
+                error $
+                    "InboxItem #" ++ show ibid ++ " neither local nor remote"
+            (Just _, Just _) ->
+                error $ "InboxItem #" ++ show ibid ++ " both local and remote"
+            (Just act, Nothing) -> Left $ persistJSONValue act
+            (Nothing, Just obj) -> Right $ persistJSONValue obj
 
 getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
 getProjectInboxR _ _ = error "TODO implement getProjectInboxR"

src/Vervis/Migration.hs

@@ -46,7 +46,8 @@ import Text.Email.Validate (unsafeEmailAddress)
 import Web.PathPieces (toPathPiece)
 
 import qualified Database.Esqueleto as E
-import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault)
+import qualified Database.Persist.Schema as S
+import qualified Database.Persist.Schema.Types as ST
 
 import Vervis.Migration.Model
 
@@ -70,13 +71,13 @@ changes =
     [ -- 1
       addEntities model_2016_08_04
       -- 2
-    , unchecked $ U.unsetFieldDefault "Sharer" "created"
+    , unchecked $ S.unsetFieldDefault "Sharer" "created"
       -- 3
-    , unchecked $ U.unsetFieldDefault "Project" "nextTicket"
+    , unchecked $ S.unsetFieldDefault "Project" "nextTicket"
       -- 4
-    , unchecked $ U.unsetFieldDefault "Repo" "vcs"
+    , unchecked $ S.unsetFieldDefault "Repo" "vcs"
       -- 5
-    , unchecked $ U.unsetFieldDefault "Repo" "mainBranch"
+    , unchecked $ S.unsetFieldDefault "Repo" "mainBranch"
       -- 6
     , removeField "Ticket" "done"
       -- 7
@@ -263,6 +264,16 @@ changes =
     , addFieldPrimRequired "Follow" False "manual"
       -- 68
     , addFieldPrimRequired "RemoteFollow" False "manual"
+      -- 69
+    , addEntity $ ST.Entity "InboxItem" [] []
+      -- 70
+    , addFieldRefRequiredEmpty "InboxItemLocal" "item" "InboxItem"
+      -- 71
+    , addFieldRefRequiredEmpty "InboxItemRemote" "item" "InboxItem"
+      -- 72
+    , addUnique "InboxItemLocal" $ Unique "UniqueInboxItemLocalItem" ["item"]
+      -- 73
+    , addUnique "InboxItemRemote" $ Unique "UniqueInboxItemRemoteItem" ["item"]
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

templates/person/inbox.hamlet

@@ -0,0 +1,31 @@
+$# 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/>.
+
+<p>
+  This is your personal inbox. It's basically like your personal social
+  overview page. It corresponds to the "Home" column in Mastodon, and displays
+  the items in your ActivityPub inbox collection.
+
+^{pageNav}
+
+<div>
+  $forall item <- items
+    <div><pre>
+      $case item
+        $of Left doc
+          #{AEP.encodePrettyToLazyText doc}
+        $of Right obj
+          #{TLB.toLazyText $ encodePrettyToTextBuilder obj}
+
+^{pageNav}