{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, OverloadedStrings #-}
module Web.Plugins.Core
( When(..)
, Cleanup(..)
, PluginName
, PluginsState(..)
, Plugins(..)
, Rewrite(..)
, RewriteIncoming
, RewriteOutgoing
, initPlugins
, destroyPlugins
, withPlugins
, getPluginsSt
, putPluginsSt
, addPluginState
, getPluginState
, modifyPluginState'
, modifyPluginsSt
, addHandler
, addCleanup
, addPostHook
, getPostHooks
, addPluginRouteFn
, getPluginRouteFn
, getRewriteFn
, setRewriteFn
, setTheme
, getTheme
, getConfig
, Plugin(..)
, initPlugin
, serve
) where
import Control.Applicative ((<$>))
import Control.Exception (bracketOnError)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, modifyTVar')
import Control.Monad.Trans (MonadIO(liftIO))
import Data.Binary.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as BS
import Data.Char (ord)
import Data.Data (Data, Typeable)
import Data.Dynamic (Dynamic, toDyn, fromDynamic)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.List (intersperse)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty, mconcat)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText)
import Network.HTTP.Types (encodePathSegments)
import Numeric (showIntAtBase)
data When
= Always
| OnFailure
| OnNormal
deriving (When -> When -> Bool
(When -> When -> Bool) -> (When -> When -> Bool) -> Eq When
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: When -> When -> Bool
$c/= :: When -> When -> Bool
== :: When -> When -> Bool
$c== :: When -> When -> Bool
Eq, Eq When
Eq When
-> (When -> When -> Ordering)
-> (When -> When -> Bool)
-> (When -> When -> Bool)
-> (When -> When -> Bool)
-> (When -> When -> Bool)
-> (When -> When -> When)
-> (When -> When -> When)
-> Ord When
When -> When -> Bool
When -> When -> Ordering
When -> When -> When
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: When -> When -> When
$cmin :: When -> When -> When
max :: When -> When -> When
$cmax :: When -> When -> When
>= :: When -> When -> Bool
$c>= :: When -> When -> Bool
> :: When -> When -> Bool
$c> :: When -> When -> Bool
<= :: When -> When -> Bool
$c<= :: When -> When -> Bool
< :: When -> When -> Bool
$c< :: When -> When -> Bool
compare :: When -> When -> Ordering
$ccompare :: When -> When -> Ordering
$cp1Ord :: Eq When
Ord, Int -> When -> ShowS
[When] -> ShowS
When -> String
(Int -> When -> ShowS)
-> (When -> String) -> ([When] -> ShowS) -> Show When
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [When] -> ShowS
$cshowList :: [When] -> ShowS
show :: When -> String
$cshow :: When -> String
showsPrec :: Int -> When -> ShowS
$cshowsPrec :: Int -> When -> ShowS
Show)
isWhen :: When -> When -> Bool
isWhen :: When -> When -> Bool
isWhen When
_ When
Always = Bool
True
isWhen When
x When
y = When
x When -> When -> Bool
forall a. Eq a => a -> a -> Bool
== When
y
data Cleanup = Cleanup When (IO ())
type PluginName = Text
data Rewrite
= Rewrite
| Redirect (Maybe Text)
deriving (Rewrite -> Rewrite -> Bool
(Rewrite -> Rewrite -> Bool)
-> (Rewrite -> Rewrite -> Bool) -> Eq Rewrite
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rewrite -> Rewrite -> Bool
$c/= :: Rewrite -> Rewrite -> Bool
== :: Rewrite -> Rewrite -> Bool
$c== :: Rewrite -> Rewrite -> Bool
Eq, Eq Rewrite
Eq Rewrite
-> (Rewrite -> Rewrite -> Ordering)
-> (Rewrite -> Rewrite -> Bool)
-> (Rewrite -> Rewrite -> Bool)
-> (Rewrite -> Rewrite -> Bool)
-> (Rewrite -> Rewrite -> Bool)
-> (Rewrite -> Rewrite -> Rewrite)
-> (Rewrite -> Rewrite -> Rewrite)
-> Ord Rewrite
Rewrite -> Rewrite -> Bool
Rewrite -> Rewrite -> Ordering
Rewrite -> Rewrite -> Rewrite
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rewrite -> Rewrite -> Rewrite
$cmin :: Rewrite -> Rewrite -> Rewrite
max :: Rewrite -> Rewrite -> Rewrite
$cmax :: Rewrite -> Rewrite -> Rewrite
>= :: Rewrite -> Rewrite -> Bool
$c>= :: Rewrite -> Rewrite -> Bool
> :: Rewrite -> Rewrite -> Bool
$c> :: Rewrite -> Rewrite -> Bool
<= :: Rewrite -> Rewrite -> Bool
$c<= :: Rewrite -> Rewrite -> Bool
< :: Rewrite -> Rewrite -> Bool
$c< :: Rewrite -> Rewrite -> Bool
compare :: Rewrite -> Rewrite -> Ordering
$ccompare :: Rewrite -> Rewrite -> Ordering
$cp1Ord :: Eq Rewrite
Ord, ReadPrec [Rewrite]
ReadPrec Rewrite
Int -> ReadS Rewrite
ReadS [Rewrite]
(Int -> ReadS Rewrite)
-> ReadS [Rewrite]
-> ReadPrec Rewrite
-> ReadPrec [Rewrite]
-> Read Rewrite
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Rewrite]
$creadListPrec :: ReadPrec [Rewrite]
readPrec :: ReadPrec Rewrite
$creadPrec :: ReadPrec Rewrite
readList :: ReadS [Rewrite]
$creadList :: ReadS [Rewrite]
readsPrec :: Int -> ReadS Rewrite
$creadsPrec :: Int -> ReadS Rewrite
Read, Int -> Rewrite -> ShowS
[Rewrite] -> ShowS
Rewrite -> String
(Int -> Rewrite -> ShowS)
-> (Rewrite -> String) -> ([Rewrite] -> ShowS) -> Show Rewrite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rewrite] -> ShowS
$cshowList :: [Rewrite] -> ShowS
show :: Rewrite -> String
$cshow :: Rewrite -> String
showsPrec :: Int -> Rewrite -> ShowS
$cshowsPrec :: Int -> Rewrite -> ShowS
Show, Typeable Rewrite
DataType
Constr
Typeable Rewrite
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Rewrite -> c Rewrite)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Rewrite)
-> (Rewrite -> Constr)
-> (Rewrite -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Rewrite))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Rewrite))
-> ((forall b. Data b => b -> b) -> Rewrite -> Rewrite)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r)
-> (forall u. (forall d. Data d => d -> u) -> Rewrite -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Rewrite -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite)
-> Data Rewrite
Rewrite -> DataType
Rewrite -> Constr
(forall b. Data b => b -> b) -> Rewrite -> Rewrite
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Rewrite -> c Rewrite
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Rewrite
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Rewrite -> u
forall u. (forall d. Data d => d -> u) -> Rewrite -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Rewrite
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Rewrite -> c Rewrite
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Rewrite)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Rewrite)
$cRedirect :: Constr
$cRewrite :: Constr
$tRewrite :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
gmapMp :: (forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
gmapM :: (forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Rewrite -> m Rewrite
gmapQi :: Int -> (forall d. Data d => d -> u) -> Rewrite -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Rewrite -> u
gmapQ :: (forall d. Data d => d -> u) -> Rewrite -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Rewrite -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Rewrite -> r
gmapT :: (forall b. Data b => b -> b) -> Rewrite -> Rewrite
$cgmapT :: (forall b. Data b => b -> b) -> Rewrite -> Rewrite
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Rewrite)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Rewrite)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Rewrite)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Rewrite)
dataTypeOf :: Rewrite -> DataType
$cdataTypeOf :: Rewrite -> DataType
toConstr :: Rewrite -> Constr
$ctoConstr :: Rewrite -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Rewrite
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Rewrite
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Rewrite -> c Rewrite
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Rewrite -> c Rewrite
$cp1Data :: Typeable Rewrite
Data, Typeable)
type RewriteIncoming = IO ([Text] -> [(Text, Maybe Text)] -> Maybe (Rewrite, [Text], [(Text, Maybe Text)]))
type RewriteOutgoing = IO ([Text] -> [(Text, Maybe Text)] -> Maybe ([Text], [(Text, Maybe Text)]))
data PluginsState theme n hook config st = PluginsState
{ PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsHandler :: Map PluginName (Plugins theme n hook config st -> [Text] -> n)
, PluginsState theme n hook config st -> [Cleanup]
pluginsOnShutdown :: [Cleanup]
, PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsRouteFn :: Map PluginName (Text, Dynamic)
, PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsPluginState :: Map PluginName (TVar Dynamic)
, PluginsState theme n hook config st -> Maybe theme
pluginsTheme :: Maybe theme
, PluginsState theme n hook config st -> [hook]
pluginsPostHooks :: [hook]
, PluginsState theme n hook config st -> config
pluginsConfig :: config
, PluginsState theme n hook config st -> st
pluginsState :: st
, PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
}
newtype Plugins theme m hook config st = Plugins { Plugins theme m hook config st
-> TVar (PluginsState theme m hook config st)
ptv :: TVar (PluginsState theme m hook config st) }
initPlugins :: config
-> st
-> IO (Plugins theme n hook config st)
initPlugins :: config -> st -> IO (Plugins theme n hook config st)
initPlugins config
config st
st =
do TVar (PluginsState theme n hook config st)
ptv <- STM (TVar (PluginsState theme n hook config st))
-> IO (TVar (PluginsState theme n hook config st))
forall a. STM a -> IO a
atomically (STM (TVar (PluginsState theme n hook config st))
-> IO (TVar (PluginsState theme n hook config st)))
-> STM (TVar (PluginsState theme n hook config st))
-> IO (TVar (PluginsState theme n hook config st))
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st
-> STM (TVar (PluginsState theme n hook config st))
forall a. a -> STM (TVar a)
newTVar
(PluginsState :: forall theme n hook config st.
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
-> [Cleanup]
-> Map PluginName (PluginName, Dynamic)
-> Map PluginName (TVar Dynamic)
-> Maybe theme
-> [hook]
-> config
-> st
-> Maybe (RewriteIncoming, RewriteOutgoing)
-> PluginsState theme n hook config st
PluginsState { pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsHandler = Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
forall k a. Map k a
Map.empty
, pluginsOnShutdown :: [Cleanup]
pluginsOnShutdown = []
, pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsRouteFn = Map PluginName (PluginName, Dynamic)
forall k a. Map k a
Map.empty
, pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsPluginState = Map PluginName (TVar Dynamic)
forall k a. Map k a
Map.empty
, pluginsTheme :: Maybe theme
pluginsTheme = Maybe theme
forall a. Maybe a
Nothing
, pluginsPostHooks :: [hook]
pluginsPostHooks = []
, pluginsConfig :: config
pluginsConfig = config
config
, pluginsState :: st
pluginsState = st
st
, pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite = Maybe (RewriteIncoming, RewriteOutgoing)
forall a. Maybe a
Nothing
}
)
Plugins theme n hook config st
-> IO (Plugins theme n hook config st)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (PluginsState theme n hook config st)
-> Plugins theme n hook config st
forall theme m hook config st.
TVar (PluginsState theme m hook config st)
-> Plugins theme m hook config st
Plugins TVar (PluginsState theme n hook config st)
ptv)
destroyPlugins :: When
-> Plugins theme m hook config st
-> IO ()
destroyPlugins :: When -> Plugins theme m hook config st -> IO ()
destroyPlugins When
whn (Plugins TVar (PluginsState theme m hook config st)
ptv) =
do [Cleanup]
pos <- STM [Cleanup] -> IO [Cleanup]
forall a. STM a -> IO a
atomically (STM [Cleanup] -> IO [Cleanup]) -> STM [Cleanup] -> IO [Cleanup]
forall a b. (a -> b) -> a -> b
$ PluginsState theme m hook config st -> [Cleanup]
forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsOnShutdown (PluginsState theme m hook config st -> [Cleanup])
-> STM (PluginsState theme m hook config st) -> STM [Cleanup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme m hook config st)
-> STM (PluginsState theme m hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme m hook config st)
ptv
(Cleanup -> IO ()) -> [Cleanup] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (When -> Cleanup -> IO ()
cleanup When
whn) [Cleanup]
pos
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
cleanup :: When -> Cleanup -> IO ()
cleanup When
w (Cleanup When
w' IO ()
action)
| When -> When -> Bool
isWhen When
w When
w' = IO ()
action
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
withPlugins :: config
-> st
-> (Plugins theme m hook config st -> IO a) -> IO a
withPlugins :: config -> st -> (Plugins theme m hook config st -> IO a) -> IO a
withPlugins config
config st
st Plugins theme m hook config st -> IO a
action =
IO (Plugins theme m hook config st)
-> (Plugins theme m hook config st -> IO ())
-> (Plugins theme m hook config st -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (config -> st -> IO (Plugins theme m hook config st)
forall config st theme n hook.
config -> st -> IO (Plugins theme n hook config st)
initPlugins config
config st
st)
(When -> Plugins theme m hook config st -> IO ()
forall theme m hook config st.
When -> Plugins theme m hook config st -> IO ()
destroyPlugins When
OnFailure)
(\Plugins theme m hook config st
p -> do a
r <- Plugins theme m hook config st -> IO a
action Plugins theme m hook config st
p ; When -> Plugins theme m hook config st -> IO ()
forall theme m hook config st.
When -> Plugins theme m hook config st -> IO ()
destroyPlugins When
OnNormal Plugins theme m hook config st
p; a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r)
getPluginsConfig :: (MonadIO m) => Plugins theme n hook config st
-> m config
getPluginsConfig :: Plugins theme n hook config st -> m config
getPluginsConfig (Plugins TVar (PluginsState theme n hook config st)
tps) =
IO config -> m config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO config -> m config) -> IO config -> m config
forall a b. (a -> b) -> a -> b
$ STM config -> IO config
forall a. STM a -> IO a
atomically (STM config -> IO config) -> STM config -> IO config
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st -> config
forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsConfig (PluginsState theme n hook config st -> config)
-> STM (PluginsState theme n hook config st) -> STM config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tps
getPluginsSt :: (MonadIO m) => Plugins theme n hook config st
-> m st
getPluginsSt :: Plugins theme n hook config st -> m st
getPluginsSt (Plugins TVar (PluginsState theme n hook config st)
tps) =
IO st -> m st
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO st -> m st) -> IO st -> m st
forall a b. (a -> b) -> a -> b
$ STM st -> IO st
forall a. STM a -> IO a
atomically (STM st -> IO st) -> STM st -> IO st
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st -> st
forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsState (PluginsState theme n hook config st -> st)
-> STM (PluginsState theme n hook config st) -> STM st
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tps
putPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> st -> m ()
putPluginsSt :: Plugins theme n hook config st -> st -> m ()
putPluginsSt (Plugins TVar (PluginsState theme n hook config st)
tps) st
st =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsState :: st
pluginsState = st
st }
modifyPluginsSt :: (MonadIO m) => Plugins theme n hook config st
-> (st -> st)
-> m ()
modifyPluginsSt :: Plugins theme n hook config st -> (st -> st) -> m ()
modifyPluginsSt (Plugins TVar (PluginsState theme n hook config st)
tps) st -> st
f =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsState :: st
pluginsState = st -> st
f st
pluginsState }
addHandler :: (MonadIO m) =>
Plugins theme n hook config st
-> PluginName
-> (Plugins theme n hook config st -> [Text] -> n)
-> m ()
addHandler :: Plugins theme n hook config st
-> PluginName
-> (Plugins theme n hook config st -> [PluginName] -> n)
-> m ()
addHandler (Plugins TVar (PluginsState theme n hook config st)
tps) PluginName
pname Plugins theme n hook config st -> [PluginName] -> n
ph =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsHandler = PluginName
-> (Plugins theme n hook config st -> [PluginName] -> n)
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PluginName
pname Plugins theme n hook config st -> [PluginName] -> n
ph Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsHandler }
addPluginState :: (MonadIO m, Typeable state) => Plugins theme n hook config st
-> PluginName
-> state
-> m ()
addPluginState :: Plugins theme n hook config st -> PluginName -> state -> m ()
addPluginState (Plugins TVar (PluginsState theme n hook config st)
tps) PluginName
pname state
state =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
do TVar Dynamic
stateTV <- Dynamic -> STM (TVar Dynamic)
forall a. a -> STM (TVar a)
newTVar (state -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn state
state)
TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsPluginState = PluginName
-> TVar Dynamic
-> Map PluginName (TVar Dynamic)
-> Map PluginName (TVar Dynamic)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PluginName
pname TVar Dynamic
stateTV Map PluginName (TVar Dynamic)
pluginsPluginState }
getPluginState :: (MonadIO m, Typeable state) =>
Plugins theme n hook config st
-> Text
-> m (Maybe state)
getPluginState :: Plugins theme n hook config st -> PluginName -> m (Maybe state)
getPluginState (Plugins TVar (PluginsState theme n hook config st)
ptv) PluginName
pluginName =
do Map PluginName (TVar Dynamic)
states <- IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic)))
-> IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic))
forall a b. (a -> b) -> a -> b
$ STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic))
forall a. STM a -> IO a
atomically (STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic)))
-> STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic))
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsPluginState (PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic))
-> STM (PluginsState theme n hook config st)
-> STM (Map PluginName (TVar Dynamic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
ptv
case PluginName -> Map PluginName (TVar Dynamic) -> Maybe (TVar Dynamic)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginName
pluginName Map PluginName (TVar Dynamic)
states of
Maybe (TVar Dynamic)
Nothing -> Maybe state -> m (Maybe state)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe state
forall a. Maybe a
Nothing
(Just TVar Dynamic
tvar) ->
do Dynamic
dyn <- IO Dynamic -> m Dynamic
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Dynamic -> m Dynamic) -> IO Dynamic -> m Dynamic
forall a b. (a -> b) -> a -> b
$ STM Dynamic -> IO Dynamic
forall a. STM a -> IO a
atomically (STM Dynamic -> IO Dynamic) -> STM Dynamic -> IO Dynamic
forall a b. (a -> b) -> a -> b
$ TVar Dynamic -> STM Dynamic
forall a. TVar a -> STM a
readTVar TVar Dynamic
tvar
Maybe state -> m (Maybe state)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe state -> m (Maybe state)) -> Maybe state -> m (Maybe state)
forall a b. (a -> b) -> a -> b
$ Dynamic -> Maybe state
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn
modifyPluginState' :: (MonadIO m, Typeable state) =>
Plugins theme n hook config st
-> Text
-> (state -> state)
-> m ()
modifyPluginState' :: Plugins theme n hook config st
-> PluginName -> (state -> state) -> m ()
modifyPluginState' (Plugins TVar (PluginsState theme n hook config st)
ptv) PluginName
pluginName state -> state
modifier =
do Map PluginName (TVar Dynamic)
states <- IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic)))
-> IO (Map PluginName (TVar Dynamic))
-> m (Map PluginName (TVar Dynamic))
forall a b. (a -> b) -> a -> b
$ STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic))
forall a. STM a -> IO a
atomically (STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic)))
-> STM (Map PluginName (TVar Dynamic))
-> IO (Map PluginName (TVar Dynamic))
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsPluginState (PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic))
-> STM (PluginsState theme n hook config st)
-> STM (Map PluginName (TVar Dynamic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
ptv
case PluginName -> Map PluginName (TVar Dynamic) -> Maybe (TVar Dynamic)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginName
pluginName Map PluginName (TVar Dynamic)
states of
Maybe (TVar Dynamic)
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just TVar Dynamic
tvar) ->
do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Dynamic -> (Dynamic -> Dynamic) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Dynamic
tvar ((Dynamic -> Dynamic) -> STM ()) -> (Dynamic -> Dynamic) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Dynamic
d ->
case Dynamic -> Maybe state
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
d of
Maybe state
Nothing -> Dynamic
d
(Just state
st) -> state -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (state -> state
modifier state
st)
() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addCleanup :: (MonadIO m) => Plugins theme n hook config st -> When -> IO () -> m ()
addCleanup :: Plugins theme n hook config st -> When -> IO () -> m ()
addCleanup (Plugins TVar (PluginsState theme n hook config st)
tps) When
when IO ()
action =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsOnShutdown :: [Cleanup]
pluginsOnShutdown = (When -> IO () -> Cleanup
Cleanup When
when IO ()
action) Cleanup -> [Cleanup] -> [Cleanup]
forall a. a -> [a] -> [a]
: [Cleanup]
pluginsOnShutdown }
addPostHook :: (MonadIO m) =>
Plugins theme n hook config st
-> hook
-> m ()
addPostHook :: Plugins theme n hook config st -> hook -> m ()
addPostHook (Plugins TVar (PluginsState theme n hook config st)
tps) hook
postHook =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsPostHooks :: [hook]
pluginsPostHooks = hook
postHook hook -> [hook] -> [hook]
forall a. a -> [a] -> [a]
: [hook]
pluginsPostHooks }
getPostHooks :: (MonadIO m) =>
Plugins theme n hook config st
-> m [hook]
getPostHooks :: Plugins theme n hook config st -> m [hook]
getPostHooks (Plugins TVar (PluginsState theme n hook config st)
tps) =
IO [hook] -> m [hook]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [hook] -> m [hook]) -> IO [hook] -> m [hook]
forall a b. (a -> b) -> a -> b
$ STM [hook] -> IO [hook]
forall a. STM a -> IO a
atomically (STM [hook] -> IO [hook]) -> STM [hook] -> IO [hook]
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st -> [hook]
forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsPostHooks (PluginsState theme n hook config st -> [hook])
-> STM (PluginsState theme n hook config st) -> STM [hook]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tps
addPluginRouteFn :: (MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> PluginName
-> Text
-> (url -> [Text])
-> m ()
addPluginRouteFn :: Plugins theme n hook config st
-> PluginName -> PluginName -> (url -> [PluginName]) -> m ()
addPluginRouteFn (Plugins TVar (PluginsState theme n hook config st)
tpv) PluginName
pluginName PluginName
baseURI url -> [PluginName]
routeFn =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tpv ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsRouteFn = PluginName
-> (PluginName, Dynamic)
-> Map PluginName (PluginName, Dynamic)
-> Map PluginName (PluginName, Dynamic)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PluginName
pluginName (PluginName
baseURI, ((url -> [PluginName]) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn url -> [PluginName]
routeFn)) Map PluginName (PluginName, Dynamic)
pluginsRouteFn }
getPluginRouteFn :: (MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> PluginName
-> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn :: Plugins theme n hook config st
-> PluginName
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName))
getPluginRouteFn (Plugins TVar (PluginsState theme n hook config st)
ptv) PluginName
pluginName =
do
PluginsState theme n hook config st
ps <- IO (PluginsState theme n hook config st)
-> m (PluginsState theme n hook config st)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PluginsState theme n hook config st)
-> m (PluginsState theme n hook config st))
-> IO (PluginsState theme n hook config st)
-> m (PluginsState theme n hook config st)
forall a b. (a -> b) -> a -> b
$ STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st)
forall a. STM a -> IO a
atomically (STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st))
-> STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st)
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
ptv
case PluginName
-> Map PluginName (PluginName, Dynamic)
-> Maybe (PluginName, Dynamic)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginName
pluginName (PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsRouteFn PluginsState theme n hook config st
ps) of
Maybe (PluginName, Dynamic)
Nothing -> do
Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
forall a. Maybe a
Nothing
(Just (PluginName
baseURI, Dynamic
dyn)) ->
case Dynamic -> Maybe (url -> [PluginName])
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
Maybe (url -> [PluginName])
Nothing -> Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
forall a. Maybe a
Nothing
(Just url -> [PluginName]
showFn) ->
do [PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])
f <- case PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite PluginsState theme n hook config st
ps of
Maybe (RewriteIncoming, RewriteOutgoing)
Nothing -> ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])))
-> ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
forall a b. (a -> b) -> a -> b
$ \[PluginName]
pathSegments [(PluginName, Maybe PluginName)]
params -> Maybe ([PluginName], [(PluginName, Maybe PluginName)])
forall a. Maybe a
Nothing
(Just (RewriteIncoming
_, RewriteOutgoing
outgoingFn)) ->
do [PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])
f <- RewriteOutgoing
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO RewriteOutgoing
outgoingFn
([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])))
-> ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
-> m ([PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)]))
forall a b. (a -> b) -> a -> b
$ [PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])
f
Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName)))
-> Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> m (Maybe
(url -> [(PluginName, Maybe PluginName)] -> PluginName))
forall a b. (a -> b) -> a -> b
$ (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
forall a. a -> Maybe a
Just ((url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName))
-> (url -> [(PluginName, Maybe PluginName)] -> PluginName)
-> Maybe (url -> [(PluginName, Maybe PluginName)] -> PluginName)
forall a b. (a -> b) -> a -> b
$ \url
u [(PluginName, Maybe PluginName)]
p ->
let pathSegments :: [PluginName]
pathSegments = PluginName
pluginName PluginName -> [PluginName] -> [PluginName]
forall a. a -> [a] -> [a]
: (url -> [PluginName]
showFn url
u)
in let ([PluginName]
paths, [(PluginName, Maybe PluginName)]
params) =
case [PluginName]
-> [(PluginName, Maybe PluginName)]
-> Maybe ([PluginName], [(PluginName, Maybe PluginName)])
f [PluginName]
pathSegments [(PluginName, Maybe PluginName)]
p of
Maybe ([PluginName], [(PluginName, Maybe PluginName)])
Nothing -> ([PluginName]
pathSegments, [(PluginName, Maybe PluginName)]
p)
(Just ([PluginName]
pathSegments', [(PluginName, Maybe PluginName)]
p')) -> ([PluginName]
pathSegments', [(PluginName, Maybe PluginName)]
p')
in PluginName
baseURI PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> (ByteString -> PluginName
decodeUtf8 (ByteString -> PluginName) -> ByteString -> PluginName
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [PluginName] -> Builder
encodePathSegments [PluginName]
pathSegments) PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> [(PluginName, PluginName)] -> PluginName
paramsToQueryString (((PluginName, Maybe PluginName) -> (PluginName, PluginName))
-> [(PluginName, Maybe PluginName)] -> [(PluginName, PluginName)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PluginName
k, Maybe PluginName
v) -> (PluginName
k, PluginName -> Maybe PluginName -> PluginName
forall a. a -> Maybe a -> a
fromMaybe PluginName
forall a. Monoid a => a
mempty Maybe PluginName
v)) [(PluginName, Maybe PluginName)]
params)
setTheme :: (MonadIO m) =>
Plugins theme n hook config st
-> Maybe theme
-> m ()
setTheme :: Plugins theme n hook config st -> Maybe theme -> m ()
setTheme (Plugins TVar (PluginsState theme n hook config st)
tps) Maybe theme
theme =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsTheme :: Maybe theme
pluginsTheme = Maybe theme
theme }
getTheme :: (MonadIO m) =>
Plugins theme n hook config st
-> m (Maybe theme)
getTheme :: Plugins theme n hook config st -> m (Maybe theme)
getTheme (Plugins TVar (PluginsState theme n hook config st)
tvp) =
IO (Maybe theme) -> m (Maybe theme)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe theme) -> m (Maybe theme))
-> IO (Maybe theme) -> m (Maybe theme)
forall a b. (a -> b) -> a -> b
$ STM (Maybe theme) -> IO (Maybe theme)
forall a. STM a -> IO a
atomically (STM (Maybe theme) -> IO (Maybe theme))
-> STM (Maybe theme) -> IO (Maybe theme)
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st -> Maybe theme
forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsTheme (PluginsState theme n hook config st -> Maybe theme)
-> STM (PluginsState theme n hook config st) -> STM (Maybe theme)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tvp
getConfig :: (MonadIO m) =>
Plugins theme n hook config st
-> m config
getConfig :: Plugins theme n hook config st -> m config
getConfig (Plugins TVar (PluginsState theme n hook config st)
tvp) =
IO config -> m config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO config -> m config) -> IO config -> m config
forall a b. (a -> b) -> a -> b
$ STM config -> IO config
forall a. STM a -> IO a
atomically (STM config -> IO config) -> STM config -> IO config
forall a b. (a -> b) -> a -> b
$ PluginsState theme n hook config st -> config
forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsConfig (PluginsState theme n hook config st -> config)
-> STM (PluginsState theme n hook config st) -> STM config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tvp
setRewriteFn :: (MonadIO m) =>
Plugins theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
-> m ()
setRewriteFn :: Plugins theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing) -> m ()
setRewriteFn (Plugins TVar (PluginsState theme n hook config st)
tps) Maybe (RewriteIncoming, RewriteOutgoing)
f =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (PluginsState theme n hook config st)
tps ((PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ())
-> (PluginsState theme n hook config st
-> PluginsState theme n hook config st)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \ps :: PluginsState theme n hook config st
ps@PluginsState{config
st
[hook]
[Cleanup]
Maybe theme
Maybe (RewriteIncoming, RewriteOutgoing)
Map PluginName (PluginName, Dynamic)
Map PluginName (TVar Dynamic)
Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: st
pluginsConfig :: config
pluginsPostHooks :: [hook]
pluginsTheme :: Maybe theme
pluginsPluginState :: Map PluginName (TVar Dynamic)
pluginsRouteFn :: Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: [Cleanup]
pluginsHandler :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsRewrite :: forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsState :: forall theme n hook config st.
PluginsState theme n hook config st -> st
pluginsConfig :: forall theme n hook config st.
PluginsState theme n hook config st -> config
pluginsPostHooks :: forall theme n hook config st.
PluginsState theme n hook config st -> [hook]
pluginsTheme :: forall theme n hook config st.
PluginsState theme n hook config st -> Maybe theme
pluginsPluginState :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (TVar Dynamic)
pluginsRouteFn :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map PluginName (PluginName, Dynamic)
pluginsOnShutdown :: forall theme n hook config st.
PluginsState theme n hook config st -> [Cleanup]
pluginsHandler :: forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
..} ->
PluginsState theme n hook config st
ps { pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite = Maybe (RewriteIncoming, RewriteOutgoing)
f }
getRewriteFn :: (MonadIO m) =>
Plugins theme n hook config st
-> m (Maybe (RewriteIncoming, RewriteOutgoing))
getRewriteFn :: Plugins theme n hook config st
-> m (Maybe (RewriteIncoming, RewriteOutgoing))
getRewriteFn (Plugins TVar (PluginsState theme n hook config st)
tps) =
IO (Maybe (RewriteIncoming, RewriteOutgoing))
-> m (Maybe (RewriteIncoming, RewriteOutgoing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (RewriteIncoming, RewriteOutgoing))
-> m (Maybe (RewriteIncoming, RewriteOutgoing)))
-> IO (Maybe (RewriteIncoming, RewriteOutgoing))
-> m (Maybe (RewriteIncoming, RewriteOutgoing))
forall a b. (a -> b) -> a -> b
$ STM (Maybe (RewriteIncoming, RewriteOutgoing))
-> IO (Maybe (RewriteIncoming, RewriteOutgoing))
forall a. STM a -> IO a
atomically (STM (Maybe (RewriteIncoming, RewriteOutgoing))
-> IO (Maybe (RewriteIncoming, RewriteOutgoing)))
-> STM (Maybe (RewriteIncoming, RewriteOutgoing))
-> IO (Maybe (RewriteIncoming, RewriteOutgoing))
forall a b. (a -> b) -> a -> b
$ (PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing))
-> STM (PluginsState theme n hook config st)
-> STM (Maybe (RewriteIncoming, RewriteOutgoing))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
forall theme n hook config st.
PluginsState theme n hook config st
-> Maybe (RewriteIncoming, RewriteOutgoing)
pluginsRewrite (STM (PluginsState theme n hook config st)
-> STM (Maybe (RewriteIncoming, RewriteOutgoing)))
-> STM (PluginsState theme n hook config st)
-> STM (Maybe (RewriteIncoming, RewriteOutgoing))
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tps
data Plugin url theme n hook config st = Plugin
{ Plugin url theme n hook config st -> PluginName
pluginName :: PluginName
, Plugin url theme n hook config st
-> Plugins theme n hook config st -> IO (Maybe PluginName)
pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)
, Plugin url theme n hook config st -> [PluginName]
pluginDepends :: [PluginName]
, Plugin url theme n hook config st -> url -> [PluginName]
pluginToPathSegments :: url -> [Text]
, Plugin url theme n hook config st -> hook
pluginPostHook :: hook
}
initPlugin :: (Typeable url) =>
Plugins theme n hook config st
-> Text
-> Plugin url theme n hook config st
-> IO (Maybe Text)
initPlugin :: Plugins theme n hook config st
-> PluginName
-> Plugin url theme n hook config st
-> IO (Maybe PluginName)
initPlugin Plugins theme n hook config st
plugins PluginName
baseURI (Plugin{hook
[PluginName]
PluginName
url -> [PluginName]
Plugins theme n hook config st -> IO (Maybe PluginName)
pluginPostHook :: hook
pluginToPathSegments :: url -> [PluginName]
pluginDepends :: [PluginName]
pluginInit :: Plugins theme n hook config st -> IO (Maybe PluginName)
pluginName :: PluginName
pluginPostHook :: forall url theme n hook config st.
Plugin url theme n hook config st -> hook
pluginToPathSegments :: forall url theme n hook config st.
Plugin url theme n hook config st -> url -> [PluginName]
pluginDepends :: forall url theme n hook config st.
Plugin url theme n hook config st -> [PluginName]
pluginInit :: forall url theme n hook config st.
Plugin url theme n hook config st
-> Plugins theme n hook config st -> IO (Maybe PluginName)
pluginName :: forall url theme n hook config st.
Plugin url theme n hook config st -> PluginName
..}) =
do
Plugins theme n hook config st
-> PluginName -> PluginName -> (url -> [PluginName]) -> IO ()
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> PluginName -> PluginName -> (url -> [PluginName]) -> m ()
addPluginRouteFn Plugins theme n hook config st
plugins PluginName
pluginName PluginName
baseURI url -> [PluginName]
pluginToPathSegments
Plugins theme n hook config st -> hook -> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> hook -> m ()
addPostHook Plugins theme n hook config st
plugins hook
pluginPostHook
Plugins theme n hook config st -> IO (Maybe PluginName)
pluginInit Plugins theme n hook config st
plugins
paramsToQueryString :: [(Text, Text)] -> Text
paramsToQueryString :: [(PluginName, PluginName)] -> PluginName
paramsToQueryString [] = PluginName
forall a. Monoid a => a
mempty
paramsToQueryString [(PluginName, PluginName)]
ps = Builder -> PluginName
toStrictText (Builder -> PluginName) -> Builder -> PluginName
forall a b. (a -> b) -> a -> b
$ Builder
"?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
"&" (((PluginName, PluginName) -> Builder)
-> [(PluginName, PluginName)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (PluginName, PluginName) -> Builder
paramToQueryString [(PluginName, PluginName)]
ps) )
where
toStrictText :: Builder -> PluginName
toStrictText = Text -> PluginName
toStrict (Text -> PluginName) -> (Builder -> Text) -> Builder -> PluginName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText
isAlphaChar :: Char -> Bool
isAlphaChar :: Char -> Bool
isAlphaChar Char
c = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
isDigitChar :: Char -> Bool
isDigitChar :: Char -> Bool
isDigitChar Char
c = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
isOk :: Char -> Bool
isOk :: Char -> Bool
isOk Char
c = Char -> Bool
isAlphaChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigitChar Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c (String
":@$-_.~" :: String)
escapeChar :: Char -> Builder
escapeChar Char
c
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = Char -> Builder
singleton Char
'+'
| Char -> Bool
isOk Char
c = Char -> Builder
singleton Char
c
| Bool
otherwise = Builder
"%" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
let hexDigit :: a -> Char
hexDigit a
n
| a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
9 = String -> Char
forall a. [a] -> a
head (a -> String
forall a. Show a => a -> String
show a
n)
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
10 = Char
'A'
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
11 = Char
'B'
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
12 = Char
'C'
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
13 = Char
'D'
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
14 = Char
'E'
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
15 = Char
'F'
in case Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
16 Int -> Char
forall a. (Ord a, Num a, Show a) => a -> Char
hexDigit (Char -> Int
ord Char
c) String
"" of
[] -> Builder
"00"
[Char
x] -> String -> Builder
forall a. IsString a => String -> a
fromString [Char
'0',Char
x]
String
cs -> String -> Builder
forall a. IsString a => String -> a
fromString String
cs
escapeParam :: Text -> Builder
escapeParam :: PluginName -> Builder
escapeParam PluginName
p = (Char -> Builder -> Builder) -> Builder -> PluginName -> Builder
forall a. (Char -> a -> a) -> a -> PluginName -> a
Text.foldr (\Char
c Builder
cs -> Char -> Builder
escapeChar Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cs) Builder
forall a. Monoid a => a
mempty PluginName
p
paramToQueryString :: (Text, Text) -> Builder
paramToQueryString :: (PluginName, PluginName) -> Builder
paramToQueryString (PluginName
k,PluginName
v) = (PluginName -> Builder
escapeParam PluginName
k) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"=" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (PluginName -> Builder
escapeParam PluginName
v)
serve :: Plugins theme n hook config st
-> PluginName
-> [Text]
-> IO (Either String n)
serve :: Plugins theme n hook config st
-> PluginName -> [PluginName] -> IO (Either String n)
serve plugins :: Plugins theme n hook config st
plugins@(Plugins TVar (PluginsState theme n hook config st)
tvp) PluginName
prefix [PluginName]
path =
do PluginsState theme n hook config st
ps <- STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st)
forall a. STM a -> IO a
atomically (STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st))
-> STM (PluginsState theme n hook config st)
-> IO (PluginsState theme n hook config st)
forall a b. (a -> b) -> a -> b
$ TVar (PluginsState theme n hook config st)
-> STM (PluginsState theme n hook config st)
forall a. TVar a -> STM a
readTVar TVar (PluginsState theme n hook config st)
tvp
let phs :: Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
phs = PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
forall theme n hook config st.
PluginsState theme n hook config st
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
pluginsHandler PluginsState theme n hook config st
ps
case PluginName
-> Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
-> Maybe (Plugins theme n hook config st -> [PluginName] -> n)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginName
prefix Map
PluginName (Plugins theme n hook config st -> [PluginName] -> n)
phs of
Maybe (Plugins theme n hook config st -> [PluginName] -> n)
Nothing -> Either String n -> IO (Either String n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String n -> IO (Either String n))
-> Either String n -> IO (Either String n)
forall a b. (a -> b) -> a -> b
$ String -> Either String n
forall a b. a -> Either a b
Left (String -> Either String n) -> String -> Either String n
forall a b. (a -> b) -> a -> b
$ String
"Invalid plugin prefix: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PluginName -> String
Text.unpack PluginName
prefix
(Just Plugins theme n hook config st -> [PluginName] -> n
h) -> Either String n -> IO (Either String n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String n -> IO (Either String n))
-> Either String n -> IO (Either String n)
forall a b. (a -> b) -> a -> b
$ n -> Either String n
forall a b. b -> Either a b
Right (n -> Either String n) -> n -> Either String n
forall a b. (a -> b) -> a -> b
$ (Plugins theme n hook config st -> [PluginName] -> n
h Plugins theme n hook config st
plugins [PluginName]
path)