diff --git a/config/models b/config/models
index 6f7b885..c6fbf0c 100644
--- a/config/models
+++ b/config/models
@@ -45,6 +45,7 @@ OutboxItem
published UTCTime
InboxItem
+ unread Bool
InboxItemLocal
person PersonId
diff --git a/config/routes b/config/routes
index 3fe6edd..9012106 100644
--- a/config/routes
+++ b/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
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 3344d11..c15a1bb 100644
--- a/src/Vervis/Federation.hs
+++ b/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
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 5a0b248..f96e168 100644
--- a/src/Vervis/Foundation.hs
+++ b/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)
diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index dcac780..3ab0e9f 100644
--- a/src/Vervis/Handler/Inbox.hs
+++ b/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
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 058e4b2..01dfc6f 100644
--- a/src/Vervis/Migration.hs
+++ b/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))
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index c089583..474cb93 100644
--- a/templates/default-layout.hamlet
+++ b/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.