Implement basic notifications in DB and UI
This commit is contained in:
fr33domlover
parent
6d55b8c5d7
commit
c531f41565
7 changed files with 174 additions and 8 deletions
|
|
@ -45,6 +45,7 @@ OutboxItem
|
|||
published UTCTime
|
||||
|
||||
InboxItem
|
||||
unread Bool
|
||||
|
||||
InboxItemLocal
|
||||
person PersonId
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in a new issue