web-plugins-0.2.0: Web/Plugins/Core.hs
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, OverloadedStrings #-}
module Web.Plugins.Core
( When(..)
, Cleanup(..)
, PluginName
, PluginsState(..)
, Plugins(..)
, initPlugins
, destroyPlugins
, withPlugins
, getPluginsSt
, putPluginsSt
, addPluginState
, getPluginState
, modifyPluginsSt
, addHandler
, addCleanup
, addPostHook
, getPostHooks
, addPluginRouteFn
, getPluginRouteFn
, 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.Char (ord)
import Data.Data (Data, Typeable)
import Data.Dynamic (Dynamic, toDyn, fromDynamic)
import qualified Data.Text as Text
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.Lazy (toStrict)
import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText)
import Numeric (showIntAtBase)
-- | 'When' indicates when a clean up action should be run
data When
= Always -- ^ always run this action when 'destroyPlugins' is called
| OnFailure -- ^ only run this action if 'destroyPlugins' is called with a failure present
| OnNormal -- ^ only run this action when 'destroyPlugins' is called with a normal shutdown
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
, pluginsPluginState :: Map PluginName (TVar Dynamic) -- ^ per-plugin state
, pluginsTheme :: Maybe theme
, pluginsPostHooks :: [hook]
, pluginsConfig :: config
, pluginsState :: st
}
-- | we don't really want to give the Plugin unrestricted access to modify the PluginsState TVar. So we will use a newtype?
newtype Plugins theme m hook config st = Plugins { ptv :: TVar (PluginsState theme m hook config st) }
-- | initialize the plugins system
initPlugins :: config -- ^ initial value for the 'config' field of 'PluginsState'
-> st -- ^ initial value for the 'state' field of the 'PluginsState'
-> IO (Plugins theme n hook config st)
initPlugins config st =
do ptv <- atomically $ newTVar
(PluginsState { pluginsHandler = Map.empty
, pluginsOnShutdown = []
, pluginsRouteFn = Map.empty
, pluginsPluginState = Map.empty
, pluginsTheme = Nothing
, pluginsPostHooks = []
, pluginsConfig = config
, pluginsState = st
}
)
return (Plugins ptv)
-- | shutdown the plugins system
destroyPlugins :: When -- ^ should be 'OnFailure' or 'OnNormal'
-> Plugins theme m hook config st -- ^ handle to the plugins
-> 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 ()
-- | a bracketed combination of 'initPlugins' and 'destroyPlugins'. Takes care of passing the correct termination condition.
withPlugins :: config -- ^ initial config value
-> st -- ^ initial state value
-> (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)
------------------------------------------------------------------------------
-- PluginsSt
------------------------------------------------------------------------------
-- | get the current st value from 'Plugins'
getPluginsSt :: (MonadIO m) => Plugins theme n hook config st
-> m st
getPluginsSt (Plugins tps) =
liftIO $ atomically $ pluginsState <$> readTVar tps
-- | put the current st value from 'Plugins'
putPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> st -> m ()
putPluginsSt (Plugins tps) st =
liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsState = st }
-- | modify the current st value from 'Plugins'
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 }
-- | add a new route handler
addHandler :: (MonadIO m) => Plugins theme n hook config st
-> Text -- ^ prefix which this route handles
-> (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 }
-- | add a new plugin-local state
addPluginState :: (MonadIO m, Typeable state) => Plugins theme n hook config st
-> Text -- plugin name
-> state
-> m ()
addPluginState (Plugins tps) pname state =
liftIO $ atomically $
do stateTV <- newTVar (toDyn state)
modifyTVar' tps $ \ps@PluginsState{..} ->
ps { pluginsPluginState = Map.insert pname stateTV pluginsPluginState }
-- | Get the state for a particular plugin
--
-- per-plugin state is optional. This will return 'Nothing' if the
-- plugin did not register any local state.
getPluginState :: (MonadIO m, Typeable state) =>
Plugins theme n hook config st
-> Text -- plugin name
-> m (Maybe state)
getPluginState (Plugins ptv) pluginName =
do states <- liftIO $ atomically $ pluginsPluginState <$> readTVar ptv
case Map.lookup pluginName states of
Nothing -> return Nothing
(Just tvar) ->
do dyn <- liftIO $ atomically $ readTVar tvar
return $ fromDynamic dyn
-- | add a new cleanup action to the top of the stack
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 -- putStrLn $ "Adding route for " ++ Text.unpack pluginName
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 -- liftIO $ putStrLn $ "looking up route function for " ++ Text.unpack pluginName
routeFns <- liftIO $ atomically $ pluginsRouteFn <$> readTVar ptv
case Map.lookup pluginName routeFns of
Nothing -> do -- liftIO $ putStrLn "oops, route not found."
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
-- | NOTE: it is possible to set the URL type incorrectly here and not get a type error. How can we fix that ?
data Plugin url theme n hook config st = Plugin
{ pluginName :: PluginName
, pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)
, pluginDepends :: [Text] -- ^ plugins which much be initialized before this one can be
, 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 -- putStrLn $ "initializing " ++ (Text.unpack pluginName)
addPluginRouteFn plugins pluginName (\u p -> baseURI <> "/" <> pluginName <> pluginToPathInfo u <> paramsToQueryString (map (\(k, v) -> (k, fromMaybe mempty v)) p))
addPostHook plugins pluginPostHook
pluginInit plugins
paramsToQueryString :: [(Text, Text)] -> Text
paramsToQueryString [] = mempty
paramsToQueryString ps = toStrictText $ "?" <> mconcat (intersperse "&" (map paramToQueryString ps) )
where
toStrictText = toStrict . toLazyText
isAlphaChar :: Char -> Bool
isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
isDigitChar :: Char -> Bool
isDigitChar c = (c >= '0' && c <= '9')
isOk :: Char -> Bool
isOk c = isAlphaChar c || isDigitChar c || c `elem` ":@$-_.~"
escapeChar c
| c == ' ' = singleton '+'
| isOk c = singleton c
| otherwise = "%" <>
let hexDigit n
| n <= 9 = head (show n)
| n == 10 = 'A'
| n == 11 = 'B'
| n == 12 = 'C'
| n == 13 = 'D'
| n == 14 = 'E'
| n == 15 = 'F'
in case showIntAtBase 16 hexDigit (ord c) "" of
[] -> "00"
[x] -> fromString ['0',x]
cs -> fromString cs
escapeParam :: Text -> Builder
escapeParam p = Text.foldr (\c cs -> escapeChar c <> cs) mempty p
paramToQueryString :: (Text, Text) -> Builder
paramToQueryString (k,v) = (escapeParam k) <> "=" <> (escapeParam v)
------------------------------------------------------------------------------
-- serve
------------------------------------------------------------------------------
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)