{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}
module Clckwrks.Redirect.Monad where

import Control.Applicative           ((<$>))
import Control.Monad                 (foldM)
import Control.Monad.Fail            (MonadFail(fail))
import Control.Monad.Reader          (MonadReader(ask,local), ReaderT(runReaderT))
import Control.Monad.State           (StateT, put, get, modify)
import Control.Monad.Trans           (MonadIO(liftIO))
import qualified Data.Text.Lazy      as LT
import Clckwrks.Acid                 (GetAcidState(..))
import Clckwrks.Monad                (Content(..), ClckT(..), ClckFormT, ClckState(..), ClckPluginsSt(..), mapClckT, runClckT, withRouteClckT, getPreProcessors)
import Clckwrks.URL                  (ClckURL)
import Clckwrks.Redirect.Acid        (RedirectState(..))
import Clckwrks.Redirect.Types       ()
import Clckwrks.Redirect.URL         (RedirectURL(..), RedirectAdminURL(..))
import Clckwrks.Redirect.Types       ()
import Clckwrks.Plugin               (clckPlugin)
import Control.Monad.Trans           (lift)
import Data.Acid                     (AcidState)
import Data.Data                     (Typeable)
import qualified Data.Text           as T
import qualified Data.Text.Lazy      as TL
import Happstack.Server              (Happstack, Input, ServerPartT)
import HSP.XMLGenerator
import HSP.XML
import Text.Reform                   (CommonFormError, FormError(..))
import Web.Plugins.Core              (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn)
import Web.Routes                    (RouteT(..), showURL, withRouteT)

data RedirectConfig = RedirectConfig
    { RedirectConfig -> AcidState RedirectState
redirectState        :: AcidState RedirectState
    , RedirectConfig -> ClckURL -> [(Text, Maybe Text)] -> Text
redirectClckURL      :: ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text
    }

type RedirectT m = ClckT RedirectURL (ReaderT RedirectConfig m)
type RedirectT' url m = ClckT url (ReaderT RedirectConfig m)
type RedirectM   = ClckT RedirectURL (ReaderT RedirectConfig (ServerPartT IO))
type RedirectAdminM = ClckT RedirectAdminURL (ReaderT RedirectConfig (ServerPartT IO))


runRedirectT :: RedirectConfig -> RedirectT m a -> ClckT RedirectURL m a
runRedirectT :: RedirectConfig -> RedirectT m a -> ClckT RedirectURL m a
runRedirectT RedirectConfig
mc RedirectT m a
m = (ReaderT RedirectConfig m (a, ClckState) -> m (a, ClckState))
-> RedirectT m a -> ClckT RedirectURL m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT ReaderT RedirectConfig m (a, ClckState) -> m (a, ClckState)
f RedirectT m a
m
    where
      f :: ReaderT RedirectConfig m (a, ClckState) -> m (a, ClckState)
f ReaderT RedirectConfig m (a, ClckState)
r = ReaderT RedirectConfig m (a, ClckState)
-> RedirectConfig -> m (a, ClckState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RedirectConfig m (a, ClckState)
r RedirectConfig
mc

runRedirectT'' :: Monad m =>
               (RedirectURL -> [(T.Text, Maybe T.Text)] -> T.Text)
            -> RedirectConfig
            -> RedirectT m a
            -> ClckT url m a
runRedirectT'' :: (RedirectURL -> [(Text, Maybe Text)] -> Text)
-> RedirectConfig -> RedirectT m a -> ClckT url m a
runRedirectT'' RedirectURL -> [(Text, Maybe Text)] -> Text
showRedirectURL RedirectConfig
stripeConfig RedirectT m a
m = RouteT url (StateT ClckState m) a -> ClckT url m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState m) a -> ClckT url m a)
-> RouteT url (StateT ClckState m) a -> ClckT url m a
forall a b. (a -> b) -> a -> b
$ ((url -> [(Text, Maybe Text)] -> Text)
 -> RedirectURL -> [(Text, Maybe Text)] -> Text)
-> RouteT RedirectURL (StateT ClckState m) a
-> RouteT url (StateT ClckState m) a
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (url -> [(Text, Maybe Text)] -> Text)
-> RedirectURL -> [(Text, Maybe Text)] -> Text
forall url'.
(url' -> [(Text, Maybe Text)] -> Text)
-> RedirectURL -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT RedirectURL (StateT ClckState m) a
 -> RouteT url (StateT ClckState m) a)
-> RouteT RedirectURL (StateT ClckState m) a
-> RouteT url (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ ClckT RedirectURL m a -> RouteT RedirectURL (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT (ClckT RedirectURL m a
 -> RouteT RedirectURL (StateT ClckState m) a)
-> ClckT RedirectURL m a
-> RouteT RedirectURL (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ RedirectConfig -> RedirectT m a -> ClckT RedirectURL m a
forall (m :: * -> *) a.
RedirectConfig -> RedirectT m a -> ClckT RedirectURL m a
runRedirectT RedirectConfig
stripeConfig (RedirectT m a -> ClckT RedirectURL m a)
-> RedirectT m a -> ClckT RedirectURL m a
forall a b. (a -> b) -> a -> b
$ RedirectT m a
m
    where
      flattenURL ::   ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> (RedirectURL -> [(T.Text, Maybe T.Text)] -> T.Text))
      flattenURL :: (url' -> [(Text, Maybe Text)] -> Text)
-> RedirectURL -> [(Text, Maybe Text)] -> Text
flattenURL url' -> [(Text, Maybe Text)] -> Text
_ RedirectURL
u [(Text, Maybe Text)]
p = RedirectURL -> [(Text, Maybe Text)] -> Text
showRedirectURL RedirectURL
u [(Text, Maybe Text)]
p


-- withRouteClckT ?
flattenURLClckT :: (url1 -> [(T.Text, Maybe T.Text)] -> T.Text)
                -> ClckT url1 m a
                -> ClckT url2 m a
flattenURLClckT :: (url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 m a -> ClckT url2 m a
flattenURLClckT url1 -> [(Text, Maybe Text)] -> Text
showClckURL ClckT url1 m a
m = RouteT url2 (StateT ClckState m) a -> ClckT url2 m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url2 (StateT ClckState m) a -> ClckT url2 m a)
-> RouteT url2 (StateT ClckState m) a -> ClckT url2 m a
forall a b. (a -> b) -> a -> b
$ ((url2 -> [(Text, Maybe Text)] -> Text)
 -> url1 -> [(Text, Maybe Text)] -> Text)
-> RouteT url1 (StateT ClckState m) a
-> RouteT url2 (StateT ClckState m) a
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (url2 -> [(Text, Maybe Text)] -> Text)
-> url1 -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT url1 (StateT ClckState m) a
 -> RouteT url2 (StateT ClckState m) a)
-> RouteT url1 (StateT ClckState m) a
-> RouteT url2 (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ ClckT url1 m a -> RouteT url1 (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT url1 m a
m
    where
      flattenURL :: (url2 -> [(Text, Maybe Text)] -> Text)
-> url1 -> [(Text, Maybe Text)] -> Text
flattenURL url2 -> [(Text, Maybe Text)] -> Text
_ = \url1
u [(Text, Maybe Text)]
p -> url1 -> [(Text, Maybe Text)] -> Text
showClckURL url1
u [(Text, Maybe Text)]
p

clckT2RedirectT :: (Functor m, MonadIO m, MonadFail m, Typeable url1) =>
             ClckT url1 m a
          -> RedirectT m a
clckT2RedirectT :: ClckT url1 m a -> RedirectT m a
clckT2RedirectT ClckT url1 m a
m =
    do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT RedirectURL (ReaderT RedirectConfig m) ClckState
-> ClckT RedirectURL (ReaderT RedirectConfig m) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT RedirectURL (ReaderT RedirectConfig m) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       (Just url1 -> [(Text, Maybe Text)] -> Text
clckShowFn) <- ClckPlugins
-> Text
-> ClckT
     RedirectURL
     (ReaderT RedirectConfig m)
     (Maybe (url1 -> [(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
  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)
       (url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 (ReaderT RedirectConfig m) a -> RedirectT m a
forall url1 (m :: * -> *) a url2.
(url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 m a -> ClckT url2 m a
flattenURLClckT url1 -> [(Text, Maybe Text)] -> Text
clckShowFn (ClckT url1 (ReaderT RedirectConfig m) a -> RedirectT m a)
-> ClckT url1 (ReaderT RedirectConfig m) a -> RedirectT m a
forall a b. (a -> b) -> a -> b
$ (m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState))
-> ClckT url1 m a -> ClckT url1 (ReaderT RedirectConfig m) a
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
forall (m :: * -> *) a.
Monad m =>
m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
addReaderT ClckT url1 m a
m
    where
      addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
      addReaderT :: m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
addReaderT m (a, ClckState)
m =
          do (a
a, ClckState
cs) <- m (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (a, ClckState)
m
             (a, ClckState) -> ReaderT RedirectConfig m (a, ClckState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, ClckState
cs)

data RedirectFormError
    = RedirectCFE (CommonFormError [Input])
    | RedirectErrorInternal
      deriving Int -> RedirectFormError -> ShowS
[RedirectFormError] -> ShowS
RedirectFormError -> String
(Int -> RedirectFormError -> ShowS)
-> (RedirectFormError -> String)
-> ([RedirectFormError] -> ShowS)
-> Show RedirectFormError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedirectFormError] -> ShowS
$cshowList :: [RedirectFormError] -> ShowS
show :: RedirectFormError -> String
$cshow :: RedirectFormError -> String
showsPrec :: Int -> RedirectFormError -> ShowS
$cshowsPrec :: Int -> RedirectFormError -> ShowS
Show

instance FormError RedirectFormError where
    type ErrorInputType RedirectFormError = [Input]
    commonFormError :: CommonFormError (ErrorInputType RedirectFormError)
-> RedirectFormError
commonFormError = CommonFormError [Input] -> RedirectFormError
CommonFormError (ErrorInputType RedirectFormError)
-> RedirectFormError
RedirectCFE

instance (Functor m, Monad m) => EmbedAsChild (RedirectT m) RedirectFormError where
    asChild :: RedirectFormError -> GenChildList (RedirectT m)
asChild RedirectFormError
e = String -> GenChildList (RedirectT m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (RedirectFormError -> String
forall a. Show a => a -> String
show RedirectFormError
e)

type RedirectForm = ClckFormT RedirectFormError RedirectM

instance (Monad m) => MonadReader RedirectConfig (RedirectT' url m) where
    ask :: RedirectT' url m RedirectConfig
ask = RouteT
  url (StateT ClckState (ReaderT RedirectConfig m)) RedirectConfig
-> RedirectT' url m RedirectConfig
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT
   url (StateT ClckState (ReaderT RedirectConfig m)) RedirectConfig
 -> RedirectT' url m RedirectConfig)
-> RouteT
     url (StateT ClckState (ReaderT RedirectConfig m)) RedirectConfig
-> RedirectT' url m RedirectConfig
forall a b. (a -> b) -> a -> b
$ RouteT
  url (StateT ClckState (ReaderT RedirectConfig m)) RedirectConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (RedirectConfig -> RedirectConfig)
-> RedirectT' url m a -> RedirectT' url m a
local RedirectConfig -> RedirectConfig
f (ClckT RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
m) = RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
-> RedirectT' url m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
 -> RedirectT' url m a)
-> RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
-> RedirectT' url m a
forall a b. (a -> b) -> a -> b
$ (RedirectConfig -> RedirectConfig)
-> RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
-> RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RedirectConfig -> RedirectConfig
f RouteT url (StateT ClckState (ReaderT RedirectConfig m)) a
m

instance (Functor m, Monad m) => GetAcidState (RedirectT' url m) RedirectState where
    getAcidState :: RedirectT' url m (AcidState RedirectState)
getAcidState =
        RedirectConfig -> AcidState RedirectState
redirectState (RedirectConfig -> AcidState RedirectState)
-> ClckT url (ReaderT RedirectConfig m) RedirectConfig
-> RedirectT' url m (AcidState RedirectState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url (ReaderT RedirectConfig m) RedirectConfig
forall r (m :: * -> *). MonadReader r m => m r
ask

instance (IsName n TL.Text) => EmbedAsAttr RedirectM (Attr n RedirectURL) where
        asAttr :: Attr n RedirectURL -> GenAttributeList RedirectM
asAttr (n
n := RedirectURL
u) =
            do Text
url <- URL (XMLGenT RedirectM) -> XMLGenT RedirectM Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (XMLGenT RedirectM)
RedirectURL
u
               Attribute -> GenAttributeList RedirectM
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList RedirectM)
-> Attribute -> GenAttributeList RedirectM
forall a b. (a -> b) -> a -> b
$ (NSName, AttrValue) -> Attribute
MkAttr (n -> NSName
forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal (Text -> Text
TL.fromStrict Text
url))

instance (IsName n TL.Text) => EmbedAsAttr RedirectM (Attr n ClckURL) where
        asAttr :: Attr n ClckURL -> GenAttributeList RedirectM
asAttr (n
n := ClckURL
url) =
            do ClckURL -> [(Text, Maybe Text)] -> Text
showFn <- RedirectConfig -> ClckURL -> [(Text, Maybe Text)] -> Text
redirectClckURL (RedirectConfig -> ClckURL -> [(Text, Maybe Text)] -> Text)
-> XMLGenT RedirectM RedirectConfig
-> XMLGenT RedirectM (ClckURL -> [(Text, Maybe Text)] -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLGenT RedirectM RedirectConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
               Attribute -> GenAttributeList RedirectM
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList RedirectM)
-> Attribute -> GenAttributeList RedirectM
forall a b. (a -> b) -> a -> b
$ (NSName, AttrValue) -> Attribute
MkAttr (n -> NSName
forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal (Text -> Text
TL.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckURL -> [(Text, Maybe Text)] -> Text
showFn ClckURL
url []))

{-
-- | convert 'Markup' to 'Content' that can be embedded. Generally by running the pre-processors needed.
-- markupToContent :: (Functor m, MonadIO m, Happstack m) => Markup -> ClckT url m Content
markupToContent :: (Functor m, MonadIO m, Happstack m) =>
                   Markup
                -> ClckT url m Content
markupToContent Markup{..} =
    do clckState <- get
       transformers <- getPreProcessors (plugins clckState)
       (Just clckRouteFn) <- getPluginRouteFn (plugins clckState) (pluginName clckPlugin)
       (markup', clckState') <- liftIO $ runClckT clckRouteFn clckState (foldM (\txt pp -> pp txt) (TL.fromStrict markup) transformers)
       put clckState'
       e <- liftIO $ runPreProcessors preProcessors trust (TL.toStrict markup')
       case e of
         (Left err)   -> return (PlainText err)
         (Right html) -> return (TrustedHtml html)

{-
-- | update the 'currentRedirect' field of 'ClckState'
setCurrentRedirect :: (MonadIO m) => RedirectId -> RedirectT m ()
setCurrentRedirect pid =
    modify $ \s -> s { pageCurrent = pid }
-}
-}