{-# LANGUAGE OverloadedStrings #-}
module Clckwrks.Authenticate.Route where

import Control.Applicative         ((<$>))
import Clckwrks.Monad              (ClckT(..), plugins)
import Clckwrks.Authenticate.URL   (AuthURL(..))
import Clckwrks.Authenticate.Page.AuthModes (authModesPage)
import Clckwrks.Authenticate.Page.Login (loginPage)
import Clckwrks.Authenticate.Page.ChangePassword (changePasswordPanel)
import Clckwrks.Authenticate.Page.ResetPassword  (resetPasswordPage)
import Clckwrks.Authenticate.Page.OpenIdRealm    (openIdRealmPanel)
import Clckwrks.ProfileData.API    (Role(..), requiresRole_)
import Clckwrks.URL                (ClckURL)
-- import Clckwrks.Plugin             (clckPlugin)
import Control.Monad.State         (get)
import Control.Monad.Trans         (lift)
import qualified Data.Set          as Set
import Happstack.Authenticate.Core (AuthenticateURL)
import Happstack.Server            (Happstack, Response, ServerPartT)
import Web.Routes                  (RouteT(..), askRouteFn, runRouteT)
import Web.Plugins.Core            (getPluginRouteFn, pluginName)

-- | routeAuth
-- there is much craziness here. This should be more like clckwrks-plugin-page or something
routeAuth :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response)
          -> AuthURL
          -> ClckT AuthURL (ServerPartT IO) Response
routeAuth :: (AuthenticateURL
 -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> AuthURL -> ClckT AuthURL (ServerPartT IO) Response
routeAuth AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate AuthURL
u' =
  do AuthURL
u <- AuthURL -> ClckT AuthURL (ServerPartT IO) AuthURL
forall (m :: * -> *).
(Happstack m, Monad m) =>
AuthURL -> ClckT AuthURL m AuthURL
checkAuth AuthURL
u'
     ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT AuthURL (ServerPartT IO) ClckState
-> ClckT AuthURL (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT AuthURL (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
     ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn) <- ClckPlugins
-> Text
-> ClckT
     AuthURL
     (ServerPartT 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
p Text
"clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends
     let withClckURL :: ClckT ClckURL m a -> ClckT url m a
withClckURL ClckT ClckURL 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) -> StateT ClckState m a)
-> RouteT url (StateT ClckState m) a
forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT (((url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a)
 -> RouteT url (StateT ClckState m) a)
-> ((url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a)
-> RouteT url (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ \url -> [(Text, Maybe Text)] -> Text
_ -> RouteT ClckURL (StateT ClckState m) a
-> (ClckURL -> [(Text, Maybe Text)] -> Text)
-> StateT ClckState m a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (ClckT ClckURL m a -> RouteT ClckURL (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT ClckURL m a
m) ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn
     case AuthURL
u of
       (Auth AuthenticateURL
authenticateURL) ->
         do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT AuthURL (ServerPartT IO) ClckState
-> ClckT AuthURL (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT AuthURL (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
            ~(Just AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn) <- ClckPlugins
-> Text
-> ClckT
     AuthURL
     (ServerPartT IO)
     (Maybe (AuthURL -> [(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 Text
"authenticate"
            ServerPartT IO Response -> ClckT AuthURL (ServerPartT IO) Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ServerPartT IO Response
 -> ClckT AuthURL (ServerPartT IO) Response)
-> ServerPartT IO Response
-> ClckT AuthURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ (AuthenticateURL
 -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> (AuthenticateURL -> [(Text, Maybe Text)] -> Text)
-> AuthenticateURL
-> ServerPartT IO Response
forall url (m :: * -> *) a.
(url -> RouteT url m a)
-> (url -> [(Text, Maybe Text)] -> Text) -> url -> m a
runRouteT AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate (AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn (AuthURL -> [(Text, Maybe Text)] -> Text)
-> (AuthenticateURL -> AuthURL)
-> AuthenticateURL
-> [(Text, Maybe Text)]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticateURL -> AuthURL
Auth) AuthenticateURL
authenticateURL
       AuthURL
Login          -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT AuthURL (ServerPartT IO) Response
forall (m :: * -> *) a url. ClckT ClckURL m a -> ClckT url m a
withClckURL ClckT ClckURL (ServerPartT IO) Response
loginPage
       AuthURL
ResetPassword  -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT AuthURL (ServerPartT IO) Response
forall (m :: * -> *) a url. ClckT ClckURL m a -> ClckT url m a
withClckURL ClckT ClckURL (ServerPartT IO) Response
resetPasswordPage
       AuthURL
ChangePassword -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT AuthURL (ServerPartT IO) Response
forall (m :: * -> *) a url. ClckT ClckURL m a -> ClckT url m a
withClckURL ClckT ClckURL (ServerPartT IO) Response
changePasswordPanel
       AuthURL
OpenIdRealm    -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT AuthURL (ServerPartT IO) Response
forall (m :: * -> *) a url. ClckT ClckURL m a -> ClckT url m a
withClckURL ClckT ClckURL (ServerPartT IO) Response
openIdRealmPanel
       AuthURL
AuthModes      -> AuthURL -> ClckT AuthURL (ServerPartT IO) Response
authModesPage AuthURL
u

checkAuth :: (Happstack m, Monad m) =>
             AuthURL
          -> ClckT AuthURL m AuthURL
checkAuth :: AuthURL -> ClckT AuthURL m AuthURL
checkAuth AuthURL
url =
  do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT AuthURL m ClckState -> ClckT AuthURL m ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT AuthURL m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
     ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn) <- ClckPlugins
-> Text
-> ClckT
     AuthURL m (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
p Text
"clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends
     let requiresRole :: Set Role -> url -> ClckT u m url
requiresRole = (ClckURL -> [(Text, Maybe Text)] -> Text)
-> Set Role -> url -> ClckT u m url
forall (m :: * -> *) url u.
Happstack m =>
(ClckURL -> [(Text, Maybe Text)] -> Text)
-> Set Role -> url -> ClckT u m url
requiresRole_ ClckURL -> [(Text, Maybe Text)] -> Text
clckShowFn
     case AuthURL
url of
       (Auth {})      -> AuthURL -> ClckT AuthURL m AuthURL
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthURL
url
       AuthURL
Login          -> AuthURL -> ClckT AuthURL m AuthURL
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthURL
url
       AuthURL
ResetPassword  -> AuthURL -> ClckT AuthURL m AuthURL
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthURL
url
       AuthURL
AuthModes      -> Set Role -> AuthURL -> ClckT AuthURL m AuthURL
forall url u. Set Role -> url -> ClckT u m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator]) AuthURL
url
       AuthURL
ChangePassword -> Set Role -> AuthURL -> ClckT AuthURL m AuthURL
forall url u. Set Role -> url -> ClckT u m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Visitor]) AuthURL
url
       AuthURL
OpenIdRealm    -> Set Role -> AuthURL -> ClckT AuthURL m AuthURL
forall url u. Set Role -> url -> ClckT u m url
requiresRole ([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator]) AuthURL
url