web-plugins 0.2.9.1 → 0.4.1
raw patch · 3 files changed
Files
- Setup.hs +6/−0
- Web/Plugins/Core.hs +112/−22
- web-plugins.cabal +11/−6
Setup.hs view
@@ -1,2 +1,8 @@+#!/usr/bin/env runghc++module Main where+ import Distribution.Simple++main :: IO () main = defaultMain
Web/Plugins/Core.hs view
@@ -45,11 +45,11 @@ @ data Plugin url theme n hook config st = Plugin- { pluginName :: PluginName- , pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)- , pluginDepends :: [PluginName] -- ^ plugins which much be initialized before this one can be- , pluginToPathInfo :: url -> Text- , pluginPostHook :: hook+ { pluginName :: PluginName+ , pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)+ , pluginDepends :: [PluginName] -- ^ plugins which much be initialized before this one can be+ , pluginToPathSegments :: url -> Text+ , pluginPostHook :: hook } @ @@ -61,7 +61,7 @@ [@pluginDepends@] is a list of plugins which must be loaded before this plugin can be initialized. -[@pluginToPathInfo@] is the function that is used to convert the 'url' type to an actual URL.+[@pluginToPathSegments@] is the function that is used to convert the 'url' type to the URL path segments [@pluginPostHook@] is the hook that you want called after the system has been initialized. @@ -190,6 +190,9 @@ , PluginName , PluginsState(..) , Plugins(..)+ , Rewrite(..)+ , RewriteIncoming+ , RewriteOutgoing , initPlugins , destroyPlugins , withPlugins@@ -197,6 +200,7 @@ , putPluginsSt , addPluginState , getPluginState+ , modifyPluginState' , modifyPluginsSt , addHandler , addCleanup@@ -204,6 +208,8 @@ , getPostHooks , addPluginRouteFn , getPluginRouteFn+ , getRewriteFn+ , setRewriteFn , setTheme , getTheme , getConfig@@ -217,10 +223,14 @@ 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@@ -229,8 +239,10 @@ 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) -- | 'When' indicates when a clean up action should be run@@ -253,6 +265,18 @@ -- currently have no way to enforce that. type PluginName = Text +-- | Rewrite or Redirect+data Rewrite+ = Rewrite -- ^ rewrite the URL internally -- does not affect the URL displayed to the user+ | Redirect (Maybe Text) -- ^ perform a 303 redirect to a different URL+ deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | rewrite the URL from a Request before routing it+type RewriteIncoming = IO ([Text] -> [(Text, Maybe Text)] -> Maybe (Rewrite, [Text], [(Text, Maybe Text)]))++-- | rewrite a URL that is going to end up in a HTML document or other output+type RewriteOutgoing = IO ([Text] -> [(Text, Maybe Text)] -> Maybe ([Text], [(Text, Maybe 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@@ -261,12 +285,13 @@ 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+ , pluginsRouteFn :: Map PluginName (Text, Dynamic) -- ^ baseURI, url -> [Text] , pluginsPluginState :: Map PluginName (TVar Dynamic) -- ^ per-plugin state , pluginsTheme :: Maybe theme , pluginsPostHooks :: [hook] , pluginsConfig :: config , pluginsState :: st+ , pluginsRewrite :: Maybe (RewriteIncoming, RewriteOutgoing) -- ^ functions rewrite the incoming and outgoing URLs } -- | The 'Plugins' type is the handle to the plugins system. Generally@@ -291,6 +316,7 @@ , pluginsPostHooks = [] , pluginsConfig = config , pluginsState = st+ , pluginsRewrite = Nothing } ) return (Plugins ptv)@@ -320,6 +346,16 @@ (\p -> do r <- action p ; destroyPlugins OnNormal p; return r) ------------------------------------------------------------------------------+-- PluginsConfig+------------------------------------------------------------------------------++-- | get the current @st@ value from 'Plugins'+getPluginsConfig :: (MonadIO m) => Plugins theme n hook config st+ -> m config+getPluginsConfig (Plugins tps) =+ liftIO $ atomically $ pluginsConfig <$> readTVar tps++------------------------------------------------------------------------------ -- PluginsSt ------------------------------------------------------------------------------ @@ -380,6 +416,25 @@ do dyn <- liftIO $ atomically $ readTVar tvar return $ fromDynamic dyn +-- | modify the plugin state+--+-- If the plugin did not register any state, then this is a noop+modifyPluginState' :: (MonadIO m, Typeable state) =>+ Plugins theme n hook config st+ -> Text -- plugin name+ -> (state -> state)+ -> m ()+modifyPluginState' (Plugins ptv) pluginName modifier =+ do states <- liftIO $ atomically $ pluginsPluginState <$> readTVar ptv+ case Map.lookup pluginName states of+ Nothing -> pure ()+ (Just tvar) ->+ do liftIO $ atomically $ modifyTVar' tvar $ \d ->+ case fromDynamic d of+ Nothing -> d+ (Just st) -> toDyn (modifier st)+ pure ()+ -- | 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 =@@ -408,13 +463,13 @@ addPluginRouteFn :: (MonadIO m, Typeable url) => Plugins theme n hook config st -> PluginName- -> (url -> [(Text, Maybe Text)] -> Text)+ -> Text -- ^ baseURI+ -> (url -> [Text]) -- ^ url to path segments -> m ()-addPluginRouteFn (Plugins tpv) pluginName routeFn =+addPluginRouteFn (Plugins tpv) pluginName baseURI routeFn = liftIO $ do -- putStrLn $ "Adding route for " ++ Text.unpack pluginName atomically $ modifyTVar' tpv $ \ps@PluginsState{..} ->- ps { pluginsRouteFn = Map.insert pluginName (toDyn routeFn) pluginsRouteFn }-+ ps { pluginsRouteFn = Map.insert pluginName (baseURI, (toDyn routeFn)) pluginsRouteFn } -- | get the plugin routing function for the named plugin --@@ -425,11 +480,29 @@ -> 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+ ps <- liftIO $ atomically $ readTVar ptv+ -- check if there is a plugin with this prefix+ case Map.lookup pluginName (pluginsRouteFn ps) of Nothing -> do -- liftIO $ putStrLn "oops, route not found."- return Nothing- (Just dyn) -> return $ fromDynamic dyn+ pure Nothing+ (Just (baseURI, dyn)) ->+ -- extract the URL show function for this plugin+ case fromDynamic dyn of+ Nothing -> pure Nothing+ (Just showFn) ->+ -- get rewrite function+ do f <- case pluginsRewrite ps of+ Nothing -> pure $ \pathSegments params -> Nothing+ (Just (_, outgoingFn)) ->+ do f <- liftIO outgoingFn+ pure $ f+ pure $ Just $ \u p ->+ let pathSegments = pluginName : (showFn u)+ in let (paths, params) =+ case f pathSegments p of+ Nothing -> (pathSegments, p)+ (Just (pathSegments', p')) -> (pathSegments', p')+ in baseURI <> (decodeUtf8 $ BS.toStrict $ toLazyByteString $ encodePathSegments pathSegments) <> paramsToQueryString (map (\(k, v) -> (k, fromMaybe mempty v)) params) -- | set the current @theme@ setTheme :: (MonadIO m) =>@@ -454,13 +527,27 @@ getConfig (Plugins tvp) = liftIO $ atomically $ pluginsConfig <$> readTVar tvp +setRewriteFn :: (MonadIO m) =>+ Plugins theme n hook config st+ -> Maybe (RewriteIncoming, RewriteOutgoing)+ -> m ()+setRewriteFn (Plugins tps) f =+ liftIO $ atomically $ modifyTVar' tps $ \ps@PluginsState{..} ->+ ps { pluginsRewrite = f }++getRewriteFn :: (MonadIO m) =>+ Plugins theme n hook config st+ -> m (Maybe (RewriteIncoming, RewriteOutgoing))+getRewriteFn (Plugins tps) =+ liftIO $ atomically $ fmap pluginsRewrite $ readTVar tps+ -- | 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 :: [PluginName] -- ^ plugins which much be initialized before this one can be- , pluginToPathInfo :: url -> Text- , pluginPostHook :: hook+ { pluginName :: PluginName+ , pluginInit :: Plugins theme n hook config st -> IO (Maybe Text)+ , pluginDepends :: [PluginName] -- ^ plugins which much be initialized before this one can be+ , pluginToPathSegments :: url -> [Text] -- ^ convert url to URL path segments+ , pluginPostHook :: hook } -- | initialize a plugin@@ -471,7 +558,7 @@ -> IO (Maybe Text) -- ^ possible error message 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))+ addPluginRouteFn plugins pluginName baseURI pluginToPathSegments addPostHook plugins pluginPostHook pluginInit plugins @@ -518,12 +605,15 @@ ------------------------------------------------------------------------------ -- | serve requests using the 'Plugins' handle+--+-- NOTE: 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+ do ps <- atomically $ readTVar tvp+ let phs = pluginsHandler ps case Map.lookup prefix phs of Nothing -> return $ Left $ "Invalid plugin prefix: " ++ Text.unpack prefix (Just h) -> return $ Right $ (h plugins path)
web-plugins.cabal view
@@ -1,5 +1,5 @@ name: web-plugins-version: 0.2.9.1+version: 0.4.1 synopsis: dynamic plugin system for web applications description: This provides a simple framework for defining plugins for a web application. It is designed with the requirement that plugins can be loaded into a running@@ -11,17 +11,22 @@ maintainer: Jeremy Shaw <jeremy@n-heptane.com> category: Web build-type: Simple-cabal-version: >=1.8-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1, GHC==8.6.3+cabal-version: >=1.10+tested-with: GHC==8.0.1, GHC==8.6.3, GHC==8.8.3, GHC==8.10.1 source-repository head type: git location: git://github.com/clckwrks/web-plugins.git library+ default-language: Haskell2010 exposed-modules: Web.Plugins.Core build-depends: base > 4 && < 5,- stm >= 2.3 && < 2.6,+ binary < 0.11,+ bytestring < 0.12,+ containers >= 0.4 && < 0.7,+ http-types < 0.13, mtl >= 2.1 && < 2.3,- text >= 0.11 && < 1.3,- containers >= 0.4 && < 0.7+ stm >= 2.3 && < 2.6,+ text >= 0.11 && < 1.3+