{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Servant.Subscriber.Types where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.Aeson
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Proxy
import Data.Monoid
import Data.String (IsString, fromString)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics
import Network.URI (URI (..), pathSegments, unEscapeString)
import Servant.Links (IsElem, HasLink, MkLink, safeLink, Link)
import System.FilePath.Posix (splitPath)
import Debug.Trace (trace)
import Servant.Subscriber.Subscribable
newtype Path = Path [Text] deriving (Eq, Generic, Ord, Show, ToJSON, FromJSON)
instance IsString Path where
fromString = Path . map T.pack . splitPath
type ReferenceCount = Int
type Revision = Int
type ResourceStatusMap = Map Path (TVar (RefCounted ResourceStatus))
data ResourceStatus =
Modified Revision
| Deleted
deriving (Eq, Show)
data RefCounted a = RefCounted {
refCount :: ReferenceCount
, refValue :: a
}
instance Functor RefCounted where
fmap f (RefCounted c v) = RefCounted c (f v)
type LogRunner = forall m a. MonadIO m => LoggingT m a -> m a
data Subscriber api = Subscriber {
subState :: !(TVar ResourceStatusMap)
, entryPoint :: !Path
, runLogging :: LogRunner
}
data Event = DeleteEvent | ModifyEvent deriving (Eq)
notify :: forall api endpoint. (IsElem endpoint api, HasLink endpoint
, IsValidEndpoint endpoint, IsSubscribable endpoint api)
=> Subscriber api
-> Event
-> Proxy endpoint
-> (MkLink endpoint Link -> URI)
-> STM ()
notify subscriber event pEndpoint getLink = do
let mkPath = Path . map (T.pack . unEscapeString) . pathSegments . getLink
let sLink = safeLink (Proxy :: Proxy api) pEndpoint
let resource = mkPath $ sLink
trace ("NOTIFIED PATH:" <> show resource) (pure ())
modifyState event resource subscriber
notifyIO :: forall api endpoint. (IsElem endpoint api, HasLink endpoint
, IsValidEndpoint endpoint, IsSubscribable endpoint api)
=> Subscriber api
-> Event
-> Proxy endpoint
-> (MkLink endpoint Link -> URI)
-> IO ()
notifyIO subscriber event pEndpoint getLink = atomically $ notify subscriber event pEndpoint getLink
subscribe :: Path -> Subscriber api -> STM (TVar (RefCounted ResourceStatus))
subscribe p s = do
states <- readTVar $ subState s
let mState = Map.lookup p states
case mState of
Nothing -> do
state <- newTVar $ RefCounted 1 (Modified 0)
writeTVar (subState s) $ Map.insert p state states
return state
Just state -> do
modifyTVar' state $ \s -> s { refCount = refCount s + 1}
return state
unsubscribe :: Path -> TVar (RefCounted ResourceStatus) -> Subscriber api -> STM ()
unsubscribe p tv s = do
v <- (\a -> a { refCount = refCount a - 1}) <$> readTVar tv
if refCount v == 0
then modifyTVar' (subState s) (Map.delete p)
else writeTVar tv v
modifyState :: Event -> Path -> Subscriber api -> STM ()
modifyState event p s = do
rMap <- readTVar (subState s)
case Map.lookup p rMap of
Nothing -> return ()
Just refStatus -> do
modifyTVar refStatus $ fmap (eventHandler event)
when (event == DeleteEvent) $ modifyTVar (subState s) (Map.delete p)
eventHandler :: Event -> ResourceStatus -> ResourceStatus
eventHandler ModifyEvent = doModify
eventHandler DeleteEvent = doDelete
doDelete :: ResourceStatus -> ResourceStatus
doDelete (Modified _) = Deleted
doDelete _ = error "Resource can not be deleted - it does not exist!"
doModify :: ResourceStatus -> ResourceStatus
doModify (Modified n) = Modified (n + 1)
doModify _ = error "Resource can not be modified - it does not exist!"
toSegments :: Path -> [Text]
toSegments (Path xs) = xs