diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,8 @@ +#!/usr/bin/env runghc + +module Main where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/Web/Plugins/Core.hs b/Web/Plugins/Core.hs --- a/Web/Plugins/Core.hs +++ b/Web/Plugins/Core.hs @@ -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) 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.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 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 +