module Happstack.Authenticate.Password.Route where

import Control.Applicative   ((<$>))
import Control.Monad.Reader  (ReaderT, runReaderT)
import Data.Acid             (AcidState, closeAcidState, makeAcidic)
import Data.Acid.Local       (createCheckpointAndClose, openLocalStateFrom)
import Data.Text             (Text)
import Data.UserId           (UserId)
import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateConfig(..), AuthenticateState, AuthenticateURL, CoreError(..), toJSONError, toJSONResponse)
import Happstack.Authenticate.Password.Core (PasswordConfig(..), PasswordError(..), PasswordState, account, initialPasswordState, passwordReset, passwordRequestReset, token)
import Happstack.Authenticate.Password.Controllers (usernamePasswordCtrl)
import Happstack.Authenticate.Password.URL (PasswordURL(..), passwordAuthenticationMethod)
import Happstack.Authenticate.Password.Partials (routePartial)
import Happstack.Server      (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse)
import Happstack.Server.JMacro ()
import HSP                   (unXMLGenT)
import HSP.HTML4             (html4StrictFrag)
import Language.Javascript.JMacro (JStat)
import System.FilePath       (combine)
import Text.Shakespeare.I18N (Lang)
import Web.Routes            (PathInfo(..), RouteT(..), mapRouteT, parseSegments)

------------------------------------------------------------------------------
-- routePassword
------------------------------------------------------------------------------

routePassword :: (Happstack m) =>
                 PasswordConfig
              -> AcidState AuthenticateState
              -> AuthenticateConfig
              -> AcidState PasswordState
              -> [Text]
              -> RouteT AuthenticateURL (ReaderT [Lang] m) Response
routePassword :: PasswordConfig
-> AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routePassword PasswordConfig
passwordConfig AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig AcidState PasswordState
passwordState [Text]
pathSegments =
  case URLParser PasswordURL -> [Text] -> Either String PasswordURL
forall a. URLParser a -> [Text] -> Either String a
parseSegments URLParser PasswordURL
forall url. PathInfo url => URLParser url
fromPathSegments [Text]
pathSegments of
    (Left String
_) -> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response)
-> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall a b. (a -> b) -> a -> b
$ CoreError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError CoreError
URLDecodeFailed
    (Right PasswordURL
url) ->
      case PasswordURL
url of
        PasswordURL
Token        -> AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState PasswordState
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> AuthenticateConfig -> AcidState PasswordState -> m Response
token AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig AcidState PasswordState
passwordState
        Account Maybe (UserId, AccountURL)
mUrl -> Either PasswordError UserId -> Response
forall e a.
(RenderMessage HappstackAuthenticateI18N e, ToJSON a) =>
Either e a -> Response
toJSONResponse (Either PasswordError UserId -> Response)
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError UserId)
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AcidState AuthenticateState
-> AcidState PasswordState
-> AuthenticateConfig
-> PasswordConfig
-> Maybe (UserId, AccountURL)
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError UserId)
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> AcidState PasswordState
-> AuthenticateConfig
-> PasswordConfig
-> Maybe (UserId, AccountURL)
-> m (Either PasswordError UserId)
account AcidState AuthenticateState
authenticateState AcidState PasswordState
passwordState AuthenticateConfig
authenticateConfig PasswordConfig
passwordConfig Maybe (UserId, AccountURL)
mUrl
        (Partial PartialURL
u)  -> do XML
xml <- XMLGenT (RouteT AuthenticateURL (ReaderT [Text] m)) XML
-> RouteT AuthenticateURL (ReaderT [Text] m) XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (AcidState AuthenticateState
-> PartialURL
-> XMLGenT (RouteT AuthenticateURL (ReaderT [Text] m)) XML
forall (m :: * -> *).
(Functor m, Monad m, Happstack m) =>
AcidState AuthenticateState -> PartialURL -> Partial m XML
routePartial AcidState AuthenticateState
authenticateState PartialURL
u)
                           Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response)
-> Response -> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall a b. (a -> b) -> a -> b
$ (Maybe XMLMetaData, XML) -> Response
forall a. ToMessage a => a -> Response
toResponse (Maybe XMLMetaData
html4StrictFrag, XML
xml)
        PasswordURL
PasswordRequestReset -> Either PasswordError Text -> Response
forall e a.
(RenderMessage HappstackAuthenticateI18N e, ToJSON a) =>
Either e a -> Response
toJSONResponse (Either PasswordError Text -> Response)
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError Text)
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AuthenticateConfig
-> PasswordConfig
-> AcidState AuthenticateState
-> AcidState PasswordState
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError Text)
forall (m :: * -> *).
Happstack m =>
AuthenticateConfig
-> PasswordConfig
-> AcidState AuthenticateState
-> AcidState PasswordState
-> m (Either PasswordError Text)
passwordRequestReset AuthenticateConfig
authenticateConfig PasswordConfig
passwordConfig AcidState AuthenticateState
authenticateState AcidState PasswordState
passwordState
        PasswordURL
PasswordReset        -> Either PasswordError Text -> Response
forall e a.
(RenderMessage HappstackAuthenticateI18N e, ToJSON a) =>
Either e a -> Response
toJSONResponse (Either PasswordError Text -> Response)
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError Text)
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AcidState AuthenticateState
-> AcidState PasswordState
-> PasswordConfig
-> RouteT
     AuthenticateURL (ReaderT [Text] m) (Either PasswordError Text)
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState
-> AcidState PasswordState
-> PasswordConfig
-> m (Either PasswordError Text)
passwordReset AcidState AuthenticateState
authenticateState AcidState PasswordState
passwordState PasswordConfig
passwordConfig
        PasswordURL
UsernamePasswordCtrl -> JStat -> Response
forall a. ToMessage a => a -> Response
toResponse (JStat -> Response)
-> RouteT AuthenticateURL (ReaderT [Text] m) JStat
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteT AuthenticateURL (ReaderT [Text] m) JStat
forall (m :: * -> *). Monad m => RouteT AuthenticateURL m JStat
usernamePasswordCtrl

------------------------------------------------------------------------------
-- initPassword
------------------------------------------------------------------------------

initPassword :: PasswordConfig
             -> FilePath
             -> AcidState AuthenticateState
             -> AuthenticateConfig
             -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword :: PasswordConfig
-> String
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword PasswordConfig
passwordConfig String
basePath AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig =
  do AcidState PasswordState
passwordState <- String -> PasswordState -> IO (AcidState PasswordState)
forall st.
(IsAcidic st, SafeCopy st) =>
String -> st -> IO (AcidState st)
openLocalStateFrom (String -> String -> String
combine String
basePath String
"password") PasswordState
initialPasswordState
     let shutdown :: Bool -> IO ()
shutdown = \Bool
normal ->
           if Bool
normal
           then AcidState PasswordState -> IO ()
forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState PasswordState
passwordState
           else AcidState PasswordState -> IO ()
forall st. AcidState st -> IO ()
closeAcidState AcidState PasswordState
passwordState
         authenticationHandler :: [Text] -> RouteT AuthenticateURL n Response
authenticationHandler [Text]
pathSegments =
           do [Text]
langsOveride <- RouteT AuthenticateURL n [Text] -> RouteT AuthenticateURL n [Text]
forall (m :: * -> *) a. HasRqData m => m a -> m a
queryString (RouteT AuthenticateURL n [Text]
 -> RouteT AuthenticateURL n [Text])
-> RouteT AuthenticateURL n [Text]
-> RouteT AuthenticateURL n [Text]
forall a b. (a -> b) -> a -> b
$ String -> RouteT AuthenticateURL n [Text]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m [Text]
lookTexts' String
"_LANG"
              [Text]
langs        <- [(Text, Maybe Double)] -> [Text]
bestLanguage ([(Text, Maybe Double)] -> [Text])
-> RouteT AuthenticateURL n [(Text, Maybe Double)]
-> RouteT AuthenticateURL n [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteT AuthenticateURL n [(Text, Maybe Double)]
forall (m :: * -> *). Happstack m => m [(Text, Maybe Double)]
acceptLanguage
              (ReaderT [Text] n Response -> n Response)
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
-> RouteT AuthenticateURL n Response
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((ReaderT [Text] n Response -> [Text] -> n Response)
-> [Text] -> ReaderT [Text] n Response -> n Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT [Text] n Response -> [Text] -> n Response
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([Text]
langsOveride [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
langs)) (RouteT AuthenticateURL (ReaderT [Text] n) Response
 -> RouteT AuthenticateURL n Response)
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
-> RouteT AuthenticateURL n Response
forall a b. (a -> b) -> a -> b
$
               PasswordConfig
-> AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
forall (m :: * -> *).
Happstack m =>
PasswordConfig
-> AcidState AuthenticateState
-> AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routePassword PasswordConfig
passwordConfig AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig AcidState PasswordState
passwordState [Text]
pathSegments
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
 RouteT AuthenticateURL (ServerPartT IO) JStat)
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO ()
shutdown, (AuthenticationMethod
passwordAuthenticationMethod, AuthenticationHandler
forall (n :: * -> *).
Happstack n =>
[Text] -> RouteT AuthenticateURL n Response
authenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat
forall (m :: * -> *). Monad m => RouteT AuthenticateURL m JStat
usernamePasswordCtrl)