diff --git a/Web/Plugins/Core.hs b/Web/Plugins/Core.hs --- a/Web/Plugins/Core.hs +++ b/Web/Plugins/Core.hs @@ -59,10 +59,20 @@ isWhen Always _ = True isWhen x y = x == y +-- | A 'Cleanup' is an 'IO' action to run when the server shuts +-- down. The server can either shutdown normally or due to a +-- failure. The 'When' parameter indicates when an action should run. data Cleanup = Cleanup When (IO ()) +-- | The 'PluginName' should uniquely identify a plugin -- though we +-- currently have no way to enforce that. type PluginName = Text +-- | The 'PluginsState' record holds all the record keeping +-- information needed for loading, unloading, and invoking plugins. In +-- theory you should not be modifying or inspecting this structure +-- directly -- only calling the helper functions that modify or read +-- it. data PluginsState theme n hook config st = PluginsState { pluginsHandler :: Map PluginName (Plugins theme n hook config st -> [Text] -> n) , pluginsOnShutdown :: [Cleanup] @@ -74,10 +84,15 @@ , pluginsState :: st } --- | we don't really want to give the Plugin unrestricted access to modify the PluginsState TVar. So we will use a newtype? +-- | The 'Plugins' type is the handle to the plugins system. Generally +-- you will have exactly one 'Plugins' value in your app. +-- +-- see also 'withPlugins' newtype Plugins theme m hook config st = Plugins { ptv :: TVar (PluginsState theme m hook config st) } -- | initialize the plugins system +-- +-- see also 'withPlugins' 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) @@ -96,7 +111,9 @@ return (Plugins ptv) -- | shutdown the plugins system -destroyPlugins :: When -- ^ should be 'OnFailure' or 'OnNormal' +-- +-- see also 'withPlugins' +destroyPlugins :: When -- ^ should be 'OnFailure' or 'OnNormal' -> Plugins theme m hook config st -- ^ handle to the plugins -> IO () destroyPlugins whn (Plugins ptv) = @@ -121,7 +138,7 @@ -- PluginsSt ------------------------------------------------------------------------------ --- | get the current st value from 'Plugins' +-- | get the current @st@ value from 'Plugins' getPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> m st getPluginsSt (Plugins tps) = @@ -183,6 +200,7 @@ liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} -> ps { pluginsOnShutdown = (Cleanup when action) : pluginsOnShutdown } +-- | add a new post initialization hook addPostHook :: (MonadIO m) => Plugins theme n hook config st -> hook @@ -191,15 +209,19 @@ liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} -> ps { pluginsPostHooks = postHook : pluginsPostHooks } +-- | get all the post initialization hooks getPostHooks :: (MonadIO m) => Plugins theme n hook config st -> m [hook] getPostHooks (Plugins tps) = liftIO $ atomically $ pluginsPostHooks <$> readTVar tps +-- | add the routing function for a plugin +-- +-- see also: 'getPluginRouteFn' addPluginRouteFn :: (MonadIO m, Typeable url) => Plugins theme n hook config st - -> Text + -> PluginName -> (url -> [(Text, Maybe Text)] -> Text) -> m () addPluginRouteFn (Plugins tpv) pluginName routeFn = @@ -208,9 +230,12 @@ ps { pluginsRouteFn = Map.insert pluginName (toDyn routeFn) pluginsRouteFn } +-- | get the plugin routing function for the named plugin +-- +-- see also: 'addPluginRouteFn' getPluginRouteFn :: (MonadIO m, Typeable url) => Plugins theme n hook config st - -> Text + -> PluginName -- ^ name of plugin -> m (Maybe (url -> [(Text, Maybe Text)] -> Text)) getPluginRouteFn (Plugins ptv) pluginName = do -- liftIO $ putStrLn $ "looking up route function for " ++ Text.unpack pluginName @@ -220,6 +245,7 @@ return Nothing (Just dyn) -> return $ fromDynamic dyn +-- | set the current @theme@ setTheme :: (MonadIO m) => Plugins theme n hook config st -> Maybe theme @@ -228,12 +254,14 @@ liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} -> ps { pluginsTheme = theme } +-- | get the current @theme@ getTheme :: (MonadIO m) => Plugins theme n hook config st -> m (Maybe theme) getTheme (Plugins tvp) = liftIO $ atomically $ pluginsTheme <$> readTVar tvp +-- | get the @config@ value from the 'Plugins' type getConfig :: (MonadIO m) => Plugins theme n hook config st -> m config @@ -244,14 +272,15 @@ 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 + , pluginDepends :: [PluginName] -- ^ plugins which much be initialized before this one can be , pluginToPathInfo :: url -> Text , pluginPostHook :: hook } +-- | initialize a plugin initPlugin :: (Typeable url) => Plugins theme n hook config st - -> Text + -> PluginName -> Plugin url theme n hook config st -> IO (Maybe Text) initPlugin plugins baseURI (Plugin{..}) = @@ -260,7 +289,6 @@ addPostHook plugins pluginPostHook pluginInit plugins - paramsToQueryString :: [(Text, Text)] -> Text paramsToQueryString [] = mempty paramsToQueryString ps = toStrictText $ "?" <> mconcat (intersperse "&" (map paramToQueryString ps) ) @@ -303,9 +331,10 @@ -- serve ------------------------------------------------------------------------------ -serve :: Plugins theme n hook config st - -> Text - -> [Text] +-- | serve requests using the 'Plugins' handle +serve :: Plugins theme n hook config st -- ^ 'Plugins' handle + -> PluginName -- ^ name of the plugin to handle this request + -> [Text] -- ^ unconsume path segments to pass to handler -> IO (Either String n) serve plugins@(Plugins tvp) prefix path = do phs <- atomically $ pluginsHandler <$> readTVar tvp diff --git a/web-plugins.cabal b/web-plugins.cabal --- a/web-plugins.cabal +++ b/web-plugins.cabal @@ -1,5 +1,5 @@ name: web-plugins -version: 0.2.0 +version: 0.2.1 synopsis: dynamic plugin system for web applications homepage: http://www.happstack.com/ license: BSD3 @@ -21,4 +21,4 @@ stm == 2.4.*, mtl == 2.1.*, text == 0.11.*, - containers == 0.4.* + containers >= 0.4 && < 0.6