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 $# . -$maybe (Entity _pid person, verified) <- mperson +$maybe (Entity _pid person, verified, sharer, unread) <- mperson
$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 resend it. Or Log out. + $if unread > 0 + + 🔔${unread} $nothing
You are not logged in.