web-plugins 0.1.1 → 0.1.2
raw patch · 2 files changed
+119/−61 lines, 2 files
Files
- Web/Plugins/Core.hs +118/−60
- web-plugins.cabal +1/−1
Web/Plugins/Core.hs view
@@ -1,24 +1,56 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, OverloadedStrings #-}-module Web.Plugins.Core where+module Web.Plugins.Core+ ( When(..)+ , Cleanup(..)+ , PluginName+ , PluginsState(..)+ , Plugins(..)+ , initPlugins+ , destroyPlugins+ , withPlugins+ , getPluginsSt+ , putPluginsSt+ , modifyPluginsSt+ , addHandler+ , addCleanup+ , addPostHook+ , getPostHooks+ , addPluginRouteFn+ , getPluginRouteFn+ , setTheme+ , getTheme+ , getConfig+ , Plugin(..)+ , initPlugin+ , serve+ ) where -import Control.Applicative-import Control.Exception+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.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)--- import System.Plugins.Load+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- | OnFailure- | OnNormal+ = 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@@ -42,7 +74,10 @@ -- | 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) } -initPlugins :: config -> st -> IO (Plugins theme n 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@@ -56,7 +91,10 @@ ) return (Plugins ptv) -destroyPlugins :: When -> Plugins theme m hook config st -> IO ()+-- | 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@@ -67,29 +105,43 @@ | otherwise = return () -- | a bracketed combination of 'initPlugins' and 'destroyPlugins'. Takes care of passing the correct termination condition.-withPlugins :: config -> st -> (Plugins theme m hook config st -> IO a) -> IO a+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+------------------------------------------------------------------------------+-- PluginsSt+------------------------------------------------------------------------------ -getPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> m st+-- | 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 } -modifyPluginsSt :: (MonadIO m) => Plugins theme n hook config st -> (st -> st) -> m ()+-- | 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 } -addHandler :: (MonadIO m) => Plugins theme n hook config st -> Text -> (Plugins theme n hook config st -> [Text] -> n) -> m ()+-- | 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 }@@ -173,53 +225,59 @@ -> IO (Maybe Text) initPlugin plugins baseURI (Plugin{..}) = do -- putStrLn $ "initializing " ++ (Text.unpack pluginName)- addPluginRouteFn plugins pluginName (\u p -> baseURI <> "/" <> pluginName <> pluginToPathInfo u)+ 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 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)-{--loadPlugin :: Plugins theme a hook config st- -> Text -- ^ baseURI- -> FilePath -- ^ object file .hi- -> [FilePath] -- ^ include paths- -> IO (Maybe Text)-loadPlugin plugins baseURI obj incs =- do status <- load_ obj incs "plugin"- case status of- (LoadFailure errs) -> return $ Just $ Text.pack $ unlines errs- (LoadSuccess _module plugin) ->- do plugin plugins baseURI--loadPlugin_ :: Plugins theme a hook config st- -> Text -- ^ baseURI- -> FilePath -- ^ object file .hi- -> [FilePath] -- ^ include paths- -> IO ()-loadPlugin_ plugins baseURI obj incs =- do me <- loadPlugin plugins baseURI obj incs- case me of- Nothing -> return ()- (Just e) -> error $ Text.unpack e--loadTheme :: Plugins theme a hook config st- -> FilePath- -> [FilePath]- -> IO ()-loadTheme plugins themeObj incs =- do status <- load_ themeObj incs "theme"- case status of- (LoadFailure errs) ->- error $ unlines errs- (LoadSuccess _module theme) ->- setTheme plugins (Just theme)--}
web-plugins.cabal view
@@ -1,5 +1,5 @@ name: web-plugins-version: 0.1.1+version: 0.1.2 synopsis: dynamic plugin system for web applications homepage: http://www.happstack.com/ license: BSD3