Implement basic notifications in DB and UI

config/models

@@ -45,6 +45,7 @@ OutboxItem
     published UTCTime
 
 InboxItem
+    unread Bool
 
 InboxItemLocal
     person   PersonId

config/routes

@@ -51,6 +51,7 @@
 /s                                           SharersR             GET
 /s/#ShrIdent                                 SharerR              GET
 /s/#ShrIdent/inbox                           SharerInboxR         GET POST
+/s/#ShrIdent/notifications                   NotificationsR       GET POST
 /s/#ShrIdent/outbox                          OutboxR              GET POST
 /s/#ShrIdent/outbox/#OutboxItemKeyHashid     OutboxItemR          GET
 

src/Vervis/Federation.hs

@@ -593,7 +593,7 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
         if pidRecip == pidAuthor
             then return "Received activity authored by self, ignoring"
             else lift $ do
-                ibid <- insert InboxItem
+                ibid <- insert $ InboxItem True
                 miblid <- insertUnique $ InboxItemLocal pidRecip obid ibid
                 let recip = shr2text shrRecip
                 case miblid of
@@ -676,7 +676,7 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity =
                 jsonObj = PersistJSON raw
                 ract = RemoteActivity iidSender luActivity jsonObj now
             ractid <- either entityKey id <$> insertBy' ract
-            ibid <- insert InboxItem
+            ibid <- insert $ InboxItem True
             mibrid <- insertUnique $ InboxItemRemote pidRecip ractid ibid
             let recip = shr2text shrRecip
             case mibrid of
@@ -885,7 +885,7 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
                 -- TODO inefficient, see the other TODOs about mergeConcat
                 remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
             for_ pids $ \ pid -> do
-                ibid <- insert InboxItem
+                ibid <- insert $ InboxItem True
                 mibrid <- insertUnique $ InboxItemRemote pid ractid ibid
                 when (isNothing mibrid) $
                     delete ibid
@@ -1433,7 +1433,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                         , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
                         )
         lift $ for_ (union recipPids morePids) $ \ pid -> do
-            ibid <- insert InboxItem
+            ibid <- insert $ InboxItem True
             insert_ $ InboxItemLocal pid obid ibid
         return remotes
         where

src/Vervis/Foundation.hs

@@ -55,6 +55,7 @@ import Yesod.Default.Util   (addStaticContentExternal)
 import qualified Data.ByteString.Char8 as BC (unpack)
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.HashMap.Strict as M (lookup, insert)
+import qualified Database.Esqueleto as E
 import qualified Yesod.Core.Unsafe as Unsafe
 --import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T
@@ -211,7 +212,12 @@ instance Yesod App where
     defaultLayout widget = do
         master <- getYesod
         mmsg <- getMessage
-        mperson <- maybeAuthAllowUnverified
+        mperson <- do
+            mperson' <- maybeAuthAllowUnverified
+            for mperson' $ \ (p@(Entity pid person), verified) -> runDB $ do
+                sharer <- getJust $ personIdent person
+                [E.Value unread] <- countUnread pid
+                return (p, verified, sharer, unread :: Int)
         (title, bcs) <- breadcrumbs
 
         -- We break up the default layout into two components:
@@ -233,6 +239,22 @@ instance Yesod App where
                 federatedServers = appInstances settings
             $(widgetFile "default-layout")
         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+        where
+        countUnread pid =
+            E.select $ E.from $ \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
+                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.&&.
+                    ib E.^. InboxItemUnread E.==. E.val True
+                return $ E.count $ ib E.^. InboxItemId
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
@@ -244,6 +266,7 @@ instance Yesod App where
         (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
 
         (SharerInboxR shr          , False) -> person shr
+        (NotificationsR shr        , _   ) -> person shr
         (OutboxR shr               , True) -> person shr
 
         (GroupsR                   , True) -> personAny
@@ -692,6 +715,9 @@ instance YesodBreadcrumbs App where
         SharersR                         -> ("Sharers", Just HomeR)
         SharerR shar                     -> (shr2text shar, Just SharersR)
         SharerInboxR shr                 -> ("Inbox", Just $ SharerR shr)
+        NotificationsR shr               -> ( "Notifications"
+                                            , Just $ SharerR shr
+                                            )
 
         PeopleR                          -> ("People", Just HomeR)
 

src/Vervis/Handler/Inbox.hs

@@ -25,6 +25,8 @@ module Vervis.Handler.Inbox
     , postOutboxR
     , getActorKey1R
     , getActorKey2R
+    , getNotificationsR
+    , postNotificationsR
     )
 where
 
@@ -32,7 +34,7 @@ import Prelude
 
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
-import Control.Exception (displayException)
+import Control.Exception hiding (Handler)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger.CallStack
@@ -56,6 +58,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Time.Clock
 import Data.Time.Interval (TimeInterval, toTimeUnit)
 import Data.Time.Units (Second)
+import Data.Traversable
 import Database.Persist
 import Network.HTTP.Client (Manager, HttpException, requestFromURI)
 import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
@@ -68,7 +71,7 @@ import Yesod.Auth (requireAuth)
 import Yesod.Core
 import Yesod.Core.Json (requireJsonBody)
 import Yesod.Core.Handler
-import Yesod.Form.Fields (Textarea (..), textField, textareaField)
+import Yesod.Form.Fields
 import Yesod.Form.Functions
 import Yesod.Form.Types
 import Yesod.Persist.Core
@@ -98,6 +101,7 @@ import Yesod.Hashids
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
 
 import Data.Aeson.Local
+import Data.Either.Local
 import Data.EventTime.Local
 import Data.Paginate.Local
 import Data.Time.Clock.Local
@@ -488,3 +492,132 @@ getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
 
 getActorKey2R :: Handler TypedContent
 getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
+
+notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool))
+notificationForm defs = renderDivs $ mk
+    <$> aopt hiddenField "Inbox Item ID#" (fmap fst <$> defs)
+    <*> aopt hiddenField "New unread flag" (fmap snd <$> defs)
+    where
+    mk Nothing     Nothing       = Nothing
+    mk (Just ibid) (Just unread) = Just (ibid, unread)
+    mk _           _             = error "Missing hidden field?"
+
+getNotificationsR :: ShrIdent -> Handler Html
+getNotificationsR shr = do
+    items <- runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        pid <- getKeyBy404 $ UniquePersonIdent sid
+        map adaptItem <$> getItems pid
+    notifications <- for items $ \ (ibid, activity) -> do
+        ((_result, widget), enctype) <-
+            runFormPost $ notificationForm $ Just $ Just (ibid, False)
+        return (activity, widget, enctype)
+    ((_result, widgetAll), enctypeAll) <-
+        runFormPost $ notificationForm $ Just Nothing
+    defaultLayout $(widgetFile "person/notifications")
+    where
+    getItems pid =
+        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.&&.
+                      ib E.^. InboxItemUnread E.==. E.val True
+                E.orderBy [E.desc $ ib E.^. InboxItemId]
+                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) -> (ibid, Left $ persistJSONValue act)
+            (Nothing, Just obj) -> (ibid, Right $ persistJSONValue obj)
+
+postNotificationsR :: ShrIdent -> Handler Html
+postNotificationsR shr = do
+    ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing
+    case result of
+        FormSuccess mitem -> do
+            (multi, markedUnread) <- runDB $ do
+                sid <- getKeyBy404 $ UniqueSharer shr
+                pid <- getKeyBy404 $ UniquePersonIdent sid
+                case mitem of
+                    Nothing -> do
+                        ibids <- map E.unValue <$> getItems pid
+                        updateWhere
+                            [InboxItemId <-. ibids]
+                            [InboxItemUnread =. False]
+                        return (True, False)
+                    Just (ibid, unread) -> do
+                        mibl <- getValBy $ UniqueInboxItemLocalItem ibid
+                        mibr <- getValBy $ UniqueInboxItemRemoteItem ibid
+                        mib <-
+                            requireEitherM
+                                mibl
+                                mibr
+                                "Unused InboxItem"
+                                "InboxItem used more than once"
+                        let samePid =
+                                case mib of
+                                    Left ibl ->
+                                        inboxItemLocalPerson ibl == pid
+                                    Right ibr ->
+                                        inboxItemRemotePerson ibr == pid
+                        if samePid
+                            then do
+                                update ibid [InboxItemUnread =. unread]
+                                return (False, unread)
+                            else
+                                permissionDenied
+                                    "Notification belongs to different user"
+            setMessage $
+                if multi
+                    then "Items marked as read."
+                    else if markedUnread
+                        then "Item marked as unread."
+                        else "Item marked as read."
+        FormMissing -> do
+            setMessage "Field(s) missing"
+        FormFailure l -> do
+            setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
+    redirect $ NotificationsR shr
+    where
+    getItems pid =
+        E.select $ E.from $
+            \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
+                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.&&.
+                      ib E.^. InboxItemUnread E.==. E.val True
+                return $ ib E.^. InboxItemId
+    -- TODO copied from Vervis.Federation, put this in 1 place
+    requireEitherM
+        :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
+    requireEitherM mx my f t =
+        case requireEither mx my of
+            Left b    -> liftIO $ throwIO $ userError $ if b then t else f
+            Right exy -> return exy

src/Vervis/Migration.hs

@@ -278,6 +278,8 @@ changes =
     , addEntities model_2019_05_17
       -- 75
     , addFieldPrimOptional "RemoteActor" (Nothing :: Maybe Text) "name"
+      -- 76
+    , addFieldPrimRequired "InboxItem" False "unread"
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

templates/default-layout.hamlet

@@ -12,7 +12,7 @@ $# 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/>.
 
-$maybe (Entity _pid person, verified) <- mperson
+$maybe (Entity _pid person, verified, sharer, unread) <- mperson
   <div>
     $if verified
       You are logged in as #{personLogin person}.
@@ -22,6 +22,9 @@ $maybe (Entity _pid person, verified) <- mperson
       received a verification link by email, you can ask to
       <a href=@{ResendVerifyEmailR}>resend
       it. Or <a href=@{AuthR LogoutR}>Log out.
+    $if unread > 0
+      <a href=@{NotificationsR $ sharerIdent sharer}>
+        🔔${unread}
 $nothing
   <div>
     You are not logged in.