{-# 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
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 []))