Server.hs

-- |
-- = Back-end of the notification server
--
-- 'XNobar' can be thought of the front-end of an XMobar-specific notification
-- server. The back-end, instead, is factored out in its own module, exposed as
-- the present 'XNobar.Server' library, which implements the notification sever
-- interface according to the [Desktop Notification
-- Specification](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html).
--
-- This 'XNobar.Server' is not a notification server by itself, because it
-- does't take care of showing the notifications; instead, it dumps the
-- notifications in mutable reference that it returns when started. Howver, I
-- call it server, because here is where I implement the aforementioned
-- [DNS](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html).
--
-- The caller can therefore start the "server back-end", get a hold on the
-- returned reference, inspect it periodically, and take action accordingly for
-- showing it, dismissing it, and so on.
--
-- Another consequence of the fact that this server doesn't really show the
-- notifications is that it doesn't really make sense to talk of of some of the
-- capabilities as defined by the aforementioned
-- [DNS](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html),
-- for it. I've set as defined just 2 capabilities:
--
--      - "body", because I'm not stripping away any part of the notification
--        when putting it in the mutable storage, so not even the body,
--      - "persistence", because, again, expiring the notifications is up to the client.
--
-- The reason why the server is implemented this way is that it was always
-- meant to be the backbone of 'XNobar', which shows notifications in a
-- text-based scrolling marquee that scrolls character-by-character, that is,
-- something that needs to update every so often (say 10 times a second)
-- regardless of whether new notifications come or not, and doesn't really care
-- about the time of arrival of each notification.
{-# LANGUAGE OverloadedStrings #-}
module XNobar.Server (startServer, NotificationsRef, fetch) where

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.State.Lazy (StateT, get, modify', runStateT)
import DBus
import DBus.Client
import Data.Bifunctor (bimap)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.Semigroup (Max(getMax))
import Data.Tuple.Extra ((&&&))
import Data.Word (Word32)
import Flow ((.>))

import XNobar.Internal.Notification (parseNotif, notifyInSig, notifyOutSig, Id, makeId, CapId, uncap, NotificationsById, Notification)
import XNobar.Internal.Positive32 (toWord32)
import qualified XNobar.Internal.Notification as N (append)

-- |Mutable reference to the notifications.
--
-- This is basically a 2-ends 1-way communication channel:
--
--      - at one end, the notification server started by the caller via 'startServer' will insert new notifications
--        as it receives them,
--      - at the other end, the owner of the value returned by 'startServer' in the IO monad can extract the notifications
--        via 'fetch', atomically emptying the reference at the same time.
newtype NotificationsRef = NotificationsRef { notifs :: IORef NotificationsById }

-- |Action that starts a notification server and returns maybe a mutable
-- reference to the notifications (or nothing if the server could not start for
-- any reason).
--
-- @
--      maybeNotifs <- startServer
--      case of maybeNotifs
--              Just notifs -> -- server has started and notitifcations will be pushed on notifs as they come
--              Nothing -> -- some error occurred and the server could not start
-- @
--
-- The caller can interact with the notitications only via 'fetch'.
startServer :: IO (Maybe NotificationsRef)
startServer = do
    client <- connectSession
    reply <- requestName client "org.freedesktop.Notifications" [nameDoNotQueue]
    notifications <- initNotifs
    notify <- state2IORef
    export client "/org/freedesktop/Notifications" defaultInterface {
          interfaceName = "org.freedesktop.Notifications",
          interfaceMethods = [
          autoMethod "GetServerInformation" getServerInformation,
          autoMethod "GetCapabilities" getCapabilities,
          makeMethod "Notify" (signature_ notifyInSig) (signature_ notifyOutSig) (notify notifications)
        ]
    }
    return $ if reply == NamePrimaryOwner
                then Just notifications
                else Nothing
    where
      initNotifs :: IO NotificationsRef
      initNotifs = NotificationsRef <$> newIORef mempty

-- |Extracts the notifications from the 'NotificationsRef' returned by
-- 'startServer', and empties the reference atomically.
fetch :: NotificationsRef -- ^ The 'IORef' extracted from the IO monad value returned by 'startServer'
      -> IO NotificationsById -- ^ The notifications extracted from the first argument
fetch ns = atomicModifyIORef' (notifs ns) (const mempty &&& id)

{- Server's interface functions -}
notify :: NotificationsRef -> MethodCall -> StateT (Id, CapId) (ReaderT Client IO) Reply
notify ns mCall = do
  (currId, maxId) <- get
  let (reqId, notif) = parseNotif $ methodCallBody mCall
  when (reqId >= unwrap maxId)
    $ error "Requested id of non-existent notification"
  (assignedId, _) <- if reqId == 0
                       then get
                       else return (makeId reqId, error "This should not be used")
  when (reqId == 0) $ modify' (bimap succ succ)
  liftIO $ append ns (assignedId, notif)
  return $ ReplyReturn [toVariant $ getMax $ toWord32 assignedId]
  where
    append :: NotificationsRef -> (Id, Notification) -> IO ()
    append ns n = atomicModifyIORef' (notifs ns)
                                     ((`N.append` n) .> (,()))
    unwrap :: CapId -> Word32
    unwrap = uncap .> getMax .> toWord32 .> getMax

getServerInformation :: IO (String, String, String, String)
getServerInformation = return ("xnobar", "enrico", "0", "1.2")

getCapabilities :: IO [String]
getCapabilities = return [ "body", "persistence" ]

-- TODO: See if this can be generalized
state2IORef :: IO (NotificationsRef -> MethodCall -> ReaderT Client IO Reply)
state2IORef = do
  sref <- newIORef mempty
  return $ \ns m -> do
    s <- liftIO $ readIORef sref
    (r, s') <- runStateT (notify ns m) s
    liftIO $ writeIORef sref s'
    pure r