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
passwordConfig authenticateState :: AcidState AuthenticateState
authenticateState authenticateConfig :: AuthenticateConfig
authenticateConfig passwordState :: AcidState PasswordState
passwordState pathSegments :: [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 _) -> 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 url :: PasswordURL
url) ->
      case PasswordURL
url of
        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 mUrl :: 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 u :: 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)
        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
        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
        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
passwordConfig basePath :: String
basePath authenticateState :: AcidState AuthenticateState
authenticateState authenticateConfig :: 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 "password") PasswordState
initialPasswordState
     let shutdown :: Bool -> IO ()
shutdown = \normal :: 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 pathSegments :: [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' "_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)