{-# 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

-- | 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]
    , pluginsRouteFn     :: Map PluginName Dynamic
    , pluginsPluginState :: Map PluginName (TVar Dynamic)  -- ^ per-plugin state
    , pluginsTheme       :: Maybe theme
    , pluginsPostHooks   :: [hook]
    , pluginsConfig      :: config
    , pluginsState       :: st
    }

-- | 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)
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
--
-- 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) =
    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 }

-- | add a new post initialization hook
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 }

-- | 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
                 -> PluginName
                 -> (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 }


-- | get the plugin routing function for the named plugin
--
-- see also: 'addPluginRouteFn'
getPluginRouteFn :: (MonadIO m, Typeable url) =>
                    Plugins theme n hook config st
                 -> 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
       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

-- | set the current @theme@
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 }

-- | 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
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      :: [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
           -> PluginName
           -> 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 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
       case Map.lookup prefix phs of
         Nothing  -> return $ Left  $ "Invalid plugin prefix: " ++ Text.unpack prefix
         (Just h) -> return $ Right $ (h plugins path)