module Web.Plugins.Core where
import Control.Applicative
import Control.Exception
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, modifyTVar')
import Control.Monad.Trans (MonadIO(liftIO))
import Data.Data
import Data.Dynamic
import qualified Data.Text as Text
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
data When
= Always
| OnFailure
| OnNormal
deriving (Eq, Ord, Show)
isWhen :: When -> When -> Bool
isWhen Always _ = True
isWhen x y = x == y
data Cleanup = Cleanup When (IO ())
type PluginName = Text
data PluginsState theme n hook config st = PluginsState
{ pluginsHandler :: Map PluginName (Plugins theme n hook config st -> [Text] -> n)
, pluginsOnShutdown :: [Cleanup]
, pluginsRouteFn :: Map PluginName Dynamic
, pluginsTheme :: Maybe theme
, pluginsPostHooks :: [hook]
, pluginsConfig :: config
, pluginsState :: st
}
newtype Plugins theme m hook config st = Plugins { ptv :: TVar (PluginsState theme m hook config st) }
initPlugins :: config -> st -> IO (Plugins theme n hook config st)
initPlugins config st =
do ptv <- atomically $ newTVar
(PluginsState { pluginsHandler = Map.empty
, pluginsOnShutdown = []
, pluginsRouteFn = Map.empty
, pluginsTheme = Nothing
, pluginsPostHooks = []
, pluginsConfig = config
, pluginsState = st
}
)
return (Plugins ptv)
destroyPlugins :: When -> Plugins theme m hook config st -> IO ()
destroyPlugins whn (Plugins ptv) =
do pos <- atomically $ pluginsOnShutdown <$> readTVar ptv
mapM_ (cleanup whn) pos
return ()
where
cleanup w (Cleanup w' action)
| isWhen w w' = action
| otherwise = return ()
withPlugins :: config -> st -> (Plugins theme m hook config st -> IO a) -> IO a
withPlugins config st action =
bracketOnError (initPlugins config st)
(destroyPlugins OnFailure)
(\p -> do r <- action p ; destroyPlugins OnNormal p; return r)
getPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> m st
getPluginsSt (Plugins tps) =
liftIO $ atomically $ pluginsState <$> readTVar tps
putPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> st -> m ()
putPluginsSt (Plugins tps) st =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsState = st }
modifyPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> (st -> st) -> m ()
modifyPluginsSt (Plugins tps) f =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsState = f pluginsState }
addHandler :: (MonadIO m) => Plugins theme n hook config st -> Text -> (Plugins theme n hook config st -> [Text] -> n) -> m ()
addHandler (Plugins tps) pname ph =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsHandler = Map.insert pname ph pluginsHandler }
addCleanup :: (MonadIO m) => Plugins theme n hook config st -> When -> IO () -> m ()
addCleanup (Plugins tps) when action =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsOnShutdown = (Cleanup when action) : pluginsOnShutdown }
addPostHook :: (MonadIO m) =>
Plugins theme n hook config st
-> hook
-> m ()
addPostHook (Plugins tps) postHook =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsPostHooks = postHook : pluginsPostHooks }
getPostHooks :: (MonadIO m) =>
Plugins theme n hook config st
-> m [hook]
getPostHooks (Plugins tps) =
liftIO $ atomically $ pluginsPostHooks <$> readTVar tps
addPluginRouteFn :: (MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text
-> (url -> [(Text, Maybe Text)] -> Text)
-> m ()
addPluginRouteFn (Plugins tpv) pluginName routeFn =
liftIO $ do
atomically $ modifyTVar' tpv $ \ps@PluginsState{..} ->
ps { pluginsRouteFn = Map.insert pluginName (toDyn routeFn) pluginsRouteFn }
getPluginRouteFn :: (MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text
-> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn (Plugins ptv) pluginName =
do
routeFns <- liftIO $ atomically $ pluginsRouteFn <$> readTVar ptv
case Map.lookup pluginName routeFns of
Nothing -> do
return Nothing
(Just dyn) -> return $ fromDynamic dyn
setTheme :: (MonadIO m) =>
Plugins theme n hook config st
-> Maybe theme
-> m ()
setTheme (Plugins tps) theme =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsTheme = theme }
getTheme :: (MonadIO m) =>
Plugins theme n hook config st
-> m (Maybe theme)
getTheme (Plugins tvp) =
liftIO $ atomically $ pluginsTheme <$> readTVar tvp
getConfig :: (MonadIO m) =>
Plugins theme n hook config st
-> m config
getConfig (Plugins tvp) =
liftIO $ atomically $ pluginsConfig <$> readTVar tvp
data Plugin url theme n hook config st = Plugin
{ pluginName :: PluginName
, pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)
, pluginDepends :: [Text]
, pluginToPathInfo :: url -> Text
, pluginPostHook :: hook
}
initPlugin :: (Typeable url) =>
Plugins theme n hook config st
-> Text
-> Plugin url theme n hook config st
-> IO (Maybe Text)
initPlugin plugins baseURI (Plugin{..}) =
do
addPluginRouteFn plugins pluginName (\u p -> baseURI <> "/" <> pluginName <> pluginToPathInfo u)
addPostHook plugins pluginPostHook
pluginInit plugins
serve :: Plugins theme n hook config st -> Text -> [Text] -> IO (Either String n)
serve plugins@(Plugins tvp) prefix path =
do phs <- atomically $ pluginsHandler <$> readTVar tvp
case Map.lookup prefix phs of
Nothing -> return $ Left $ "Invalid plugin prefix: " ++ Text.unpack prefix
(Just h) -> return $ Right $ (h plugins path)