{-# LANGUAGE RecordWildCards, FlexibleContexts, OverloadedStrings #-}
module Clckwrks.Page.Plugin where

import Clckwrks                     ( ClckwrksConfig(clckTopDir), ClckState(plugins), ClckT(..), ClckURL, ClckPlugins, Theme
                                    , Role(..), ClckPluginsSt, addAdminMenu, addNavBarCallback, addPreProc, query, update
                                    )
import Clckwrks.Acid                (GetUACCT(..), SetUACCT(..))
import Clckwrks.Plugin              (clckPlugin)
import Clckwrks.Page.Acid           (PageState, GetOldUACCT(..), ClearOldUACCT(..), initialPageState)
import Clckwrks.Page.NavBarCallback (navBarCallback)
import Clckwrks.Page.Monad          (PageConfig(..), runPageT)
import Clckwrks.Page.PreProcess     (pageCmd)
import Clckwrks.Page.Route          (routePage)
import Clckwrks.Page.URL            (PageURL(..), PageAdminURL(..))
import Clckwrks.Page.Types          (PageId(..))
import Control.Applicative          ((<$>))
import Control.Monad.State          (get)
import Data.Acid                    (AcidState)
import Data.Acid.Advanced           (update', query')
import Data.Acid.Local              (createCheckpointAndClose, openLocalStateFrom,)
import Data.Text                    (Text)
import qualified Data.Text.Lazy     as TL
import Data.Maybe                   (fromMaybe)
import Data.Set                     (Set)
import qualified Data.Set           as Set
import Happstack.Server             (ServerPartT, Response, notFound, toResponse)
import System.Directory             (createDirectoryIfMissing)
import System.FilePath              ((</>))
import Web.Routes                   (toPathSegments, parseSegments, withRouteT, fromPathSegments)
import Web.Plugins.Core             (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, addPostHook, initPlugin, getConfig, getPluginRouteFn)

pageHandler :: (PageURL -> [(Text, Maybe Text)] -> Text)
              -> PageConfig
              -> ClckPlugins
              -> [Text]
              -> ClckT ClckURL (ServerPartT IO) Response
pageHandler :: (PageURL -> [(Text, Maybe Text)] -> Text)
-> PageConfig
-> ClckPlugins
-> [Text]
-> ClckT ClckURL (ServerPartT IO) Response
pageHandler PageURL -> [(Text, Maybe Text)] -> Text
showPageURL PageConfig
pageConfig ClckPlugins
plugins [Text]
paths =
    case URLParser PageURL -> [Text] -> Either String PageURL
forall a. URLParser a -> [Text] -> Either String a
parseSegments URLParser PageURL
forall url. PathInfo url => URLParser url
fromPathSegments [Text]
paths of
      (Left String
e)  -> Response -> ClckT ClckURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> ClckT ClckURL (ServerPartT IO) Response)
-> Response -> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> String
forall a. Show a => a -> String
show String
e)
      (Right PageURL
u) ->
          RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
 -> ClckT ClckURL (ServerPartT IO) Response)
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ ((ClckURL -> [(Text, Maybe Text)] -> Text)
 -> PageURL -> [(Text, Maybe Text)] -> Text)
-> RouteT PageURL (StateT ClckState (ServerPartT IO)) Response
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (ClckURL -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
forall url'.
(url' -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT PageURL (StateT ClckState (ServerPartT IO)) Response
 -> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response)
-> RouteT PageURL (StateT ClckState (ServerPartT IO)) Response
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
forall a b. (a -> b) -> a -> b
$ ClckT PageURL (ServerPartT IO) Response
-> RouteT PageURL (StateT ClckState (ServerPartT IO)) Response
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT (ClckT PageURL (ServerPartT IO) Response
 -> RouteT PageURL (StateT ClckState (ServerPartT IO)) Response)
-> ClckT PageURL (ServerPartT IO) Response
-> RouteT PageURL (StateT ClckState (ServerPartT IO)) Response
forall a b. (a -> b) -> a -> b
$ PageConfig
-> PageT (ServerPartT IO) Response
-> ClckT PageURL (ServerPartT IO) Response
forall (m :: * -> *) a.
PageConfig -> PageT m a -> ClckT PageURL m a
runPageT PageConfig
pageConfig (PageT (ServerPartT IO) Response
 -> ClckT PageURL (ServerPartT IO) Response)
-> PageT (ServerPartT IO) Response
-> ClckT PageURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ PageURL -> PageT (ServerPartT IO) Response
routePage PageURL
u
    where
      flattenURL ::   ((url' -> [(Text, Maybe Text)] -> Text) -> (PageURL -> [(Text, Maybe Text)] -> Text))
      flattenURL :: (url' -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
flattenURL url' -> [(Text, Maybe Text)] -> Text
_ PageURL
u [(Text, Maybe Text)]
p = PageURL -> [(Text, Maybe Text)] -> Text
showPageURL PageURL
u [(Text, Maybe Text)]
p

pageInit :: ClckPlugins
         -> IO (Maybe Text)
pageInit :: ClckPlugins -> IO (Maybe Text)
pageInit ClckPlugins
plugins =
    do ~(Just PageURL -> [(Text, Maybe Text)] -> Text
pageShowFn) <- ClckPlugins
-> Text -> IO (Maybe (PageURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
plugins (Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
pagePlugin)
       ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn) <- ClckPlugins
-> Text -> IO (Maybe (ClckURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
plugins (Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
clckPlugin)
       Maybe String
mTopDir <- ClckwrksConfig -> Maybe String
clckTopDir (ClckwrksConfig -> Maybe String)
-> IO ClckwrksConfig -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckPlugins -> IO ClckwrksConfig
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m config
getConfig ClckPlugins
plugins
       let basePath :: String
basePath = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_state" (\String
td -> String
td String -> String -> String
</> String
"_state") Maybe String
mTopDir -- FIXME
           pageDir :: String
pageDir  = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_page" (\String
td -> String
td String -> String -> String
</> String
"_page") Maybe String
mTopDir
           cacheDir :: String
cacheDir = String
pageDir String -> String -> String
</> String
"_cache"
       Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir

       PageState
ips  <- IO PageState
initialPageState
       AcidState PageState
acid <- String -> PageState -> IO (AcidState PageState)
forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (AcidState st)
openLocalStateFrom (String
basePath String -> String -> String
</> String
"page") PageState
ips
       ClckPlugins -> When -> IO () -> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> When -> IO () -> m ()
addCleanup ClckPlugins
plugins When
Always (AcidState PageState -> IO ()
forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState PageState
acid)

       let pageConfig :: PageConfig
pageConfig = PageConfig :: AcidState PageState
-> (ClckURL -> [(Text, Maybe Text)] -> Text) -> PageConfig
PageConfig { pageState :: AcidState PageState
pageState     = AcidState PageState
acid
                                   , pageClckURL :: ClckURL -> [(Text, Maybe Text)] -> Text
pageClckURL   = ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn
                                   }

       ClckPlugins
-> (forall (mm :: * -> *).
    (Functor mm, MonadIO mm, Happstack mm) =>
    Text -> ClckT ClckURL mm Text)
-> IO ()
forall (m :: * -> *) theme n hook config.
MonadIO m =>
Plugins theme n hook config ClckPluginsSt
-> (forall (mm :: * -> *).
    (Functor mm, MonadIO mm, Happstack mm) =>
    Text -> ClckT ClckURL mm Text)
-> m ()
addPreProc ClckPlugins
plugins (AcidState PageState
-> (PageURL -> [(Text, Maybe Text)] -> Text)
-> Text
-> ClckT ClckURL mm Text
forall (m :: * -> *) url.
(Functor m, MonadIO m) =>
AcidState PageState
-> (PageURL -> [(Text, Maybe Text)] -> Text)
-> Text
-> ClckT url m Text
pageCmd AcidState PageState
acid PageURL -> [(Text, Maybe Text)] -> Text
pageShowFn)
       ClckPlugins -> ClckT ClckURL IO (String, [NamedLink]) -> IO ()
forall (m :: * -> *) theme n hook config.
MonadIO m =>
Plugins theme n hook config ClckPluginsSt
-> ClckT ClckURL IO (String, [NamedLink]) -> m ()
addNavBarCallback ClckPlugins
plugins (AcidState PageState
-> (PageURL -> [(Text, Maybe Text)] -> Text)
-> ClckT ClckURL IO (String, [NamedLink])
navBarCallback AcidState PageState
acid PageURL -> [(Text, Maybe Text)] -> Text
pageShowFn)
       ClckPlugins
-> Text
-> (ClckPlugins
    -> [Text] -> ClckT ClckURL (ServerPartT IO) Response)
-> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st
-> Text -> (Plugins theme n hook config st -> [Text] -> n) -> m ()
addHandler ClckPlugins
plugins (Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
pagePlugin) ((PageURL -> [(Text, Maybe Text)] -> Text)
-> PageConfig
-> ClckPlugins
-> [Text]
-> ClckT ClckURL (ServerPartT IO) Response
pageHandler PageURL -> [(Text, Maybe Text)] -> Text
pageShowFn PageConfig
pageConfig)
       ClckPlugins -> ClckT ClckURL IO () -> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> hook -> m ()
addPostHook ClckPlugins
plugins (AcidState PageState -> ClckT ClckURL IO ()
forall url. AcidState PageState -> ClckT url IO ()
migrateUACCT AcidState PageState
acid)

       Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing

addPageAdminMenu :: ClckT url IO ()
addPageAdminMenu :: ClckT url IO ()
addPageAdminMenu =
    do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url IO ClckState -> ClckT url IO ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url IO ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       ~(Just PageURL -> [(Text, Maybe Text)] -> Text
pageShowURL) <- ClckPlugins
-> Text
-> ClckT url IO (Maybe (PageURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
p (Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
pagePlugin)
       let newPageURL :: Text
newPageURL    = PageURL -> [(Text, Maybe Text)] -> Text
pageShowURL (PageAdminURL -> PageURL
PageAdmin PageAdminURL
NewPage) []
           pagesURL :: Text
pagesURL      = PageURL -> [(Text, Maybe Text)] -> Text
pageShowURL (PageAdminURL -> PageURL
PageAdmin PageAdminURL
Pages) []
           feedConfigURL :: Text
feedConfigURL = PageURL -> [(Text, Maybe Text)] -> Text
pageShowURL (PageAdminURL -> PageURL
PageAdmin PageAdminURL
EditFeedConfig) []
       (Text, [(Set Role, Text, Text)]) -> ClckT url IO ()
forall (m :: * -> *) url.
Monad m =>
(Text, [(Set Role, Text, Text)]) -> ClckT url m ()
addAdminMenu (Text
"Pages/Posts"
                    , [ ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator, Role
Editor], Text
"New Page/Post"   , Text
newPageURL)
                      , ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator, Role
Editor], Text
"Edit Page/Post"  , Text
pagesURL)
                      , ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator, Role
Editor], Text
"Edit Feed Config", Text
feedConfigURL)
                      ]
                    )

migrateUACCT :: AcidState PageState -> ClckT url IO ()
migrateUACCT :: AcidState PageState -> ClckT url IO ()
migrateUACCT AcidState PageState
acidPageState =
    do Maybe UACCT
mOldUACCT <- AcidState (EventState GetOldUACCT)
-> GetOldUACCT -> ClckT url IO (EventResult GetOldUACCT)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetOldUACCT)
AcidState PageState
acidPageState GetOldUACCT
GetOldUACCT
       case Maybe UACCT
mOldUACCT of
         Maybe UACCT
Nothing -> () -> ClckT url IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (Just UACCT
uacct) ->
             do Maybe UACCT
mNewUACCT <- GetUACCT -> ClckT url IO (EventResult GetUACCT)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetUACCT
GetUACCT
                case Maybe UACCT
mNewUACCT of
                  Maybe UACCT
Nothing -> SetUACCT -> ClckT url IO (EventResult SetUACCT)
forall event (m :: * -> *).
(UpdateEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
update (Maybe UACCT -> SetUACCT
SetUACCT (Maybe UACCT -> SetUACCT) -> Maybe UACCT -> SetUACCT
forall a b. (a -> b) -> a -> b
$ UACCT -> Maybe UACCT
forall a. a -> Maybe a
Just UACCT
uacct)
                  (Just UACCT
_) -> AcidState (EventState ClearOldUACCT)
-> ClearOldUACCT -> ClckT url IO (EventResult ClearOldUACCT)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState ClearOldUACCT)
AcidState PageState
acidPageState ClearOldUACCT
ClearOldUACCT

pagePlugin :: Plugin PageURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt
pagePlugin :: Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
pagePlugin = Plugin :: forall url theme n hook config st.
Text
-> (Plugins theme n hook config st -> IO (Maybe Text))
-> [Text]
-> (url -> [Text])
-> hook
-> Plugin url theme n hook config st
Plugin
    { pluginName :: Text
pluginName           = Text
"page"
    , pluginInit :: ClckPlugins -> IO (Maybe Text)
pluginInit           = ClckPlugins -> IO (Maybe Text)
pageInit
    , pluginDepends :: [Text]
pluginDepends        = [Text
"clck"]
    , pluginToPathSegments :: PageURL -> [Text]
pluginToPathSegments = PageURL -> [Text]
forall url. PathInfo url => url -> [Text]
toPathSegments
    , pluginPostHook :: ClckT ClckURL IO ()
pluginPostHook       = ClckT ClckURL IO ()
forall url. ClckT url IO ()
addPageAdminMenu
    }

plugin :: ClckPlugins -- ^ plugins
       -> Text        -- ^ baseURI
       -> IO (Maybe Text)
plugin :: ClckPlugins -> Text -> IO (Maybe Text)
plugin ClckPlugins
plugins Text
baseURI =
    ClckPlugins
-> Text
-> Plugin
     PageURL
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
-> IO (Maybe Text)
forall url theme n hook config st.
Typeable url =>
Plugins theme n hook config st
-> Text -> Plugin url theme n hook config st -> IO (Maybe Text)
initPlugin ClckPlugins
plugins Text
baseURI Plugin
  PageURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
pagePlugin