module Happstack.Authenticate.Password.Route where

import Control.Applicative   ((<$>))
import Control.Monad.Reader  (ReaderT, runReaderT)
import Control.Monad.Trans   (MonadIO(liftIO))
import Control.Concurrent.STM      (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar)
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) =>
                 TVar PasswordConfig
              -> AcidState AuthenticateState
              -> TVar AuthenticateConfig
              -> AcidState PasswordState
              -> [Text]
              -> RouteT AuthenticateURL (ReaderT [Lang] m) Response
routePassword :: TVar PasswordConfig
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routePassword TVar PasswordConfig
passwordConfigTV AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV 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) ->
      do AuthenticateConfig
authenticateConfig <- IO AuthenticateConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AuthenticateConfig
 -> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig)
-> IO AuthenticateConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) AuthenticateConfig
forall a b. (a -> b) -> a -> b
$ STM AuthenticateConfig -> IO AuthenticateConfig
forall a. STM a -> IO a
atomically (STM AuthenticateConfig -> IO AuthenticateConfig)
-> STM AuthenticateConfig -> IO AuthenticateConfig
forall a b. (a -> b) -> a -> b
$ TVar AuthenticateConfig -> STM AuthenticateConfig
forall a. TVar a -> STM a
readTVar TVar AuthenticateConfig
authenticateConfigTV
         PasswordConfig
passwordConfig     <- IO PasswordConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) PasswordConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PasswordConfig
 -> RouteT AuthenticateURL (ReaderT [Text] m) PasswordConfig)
-> IO PasswordConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) PasswordConfig
forall a b. (a -> b) -> a -> b
$ STM PasswordConfig -> IO PasswordConfig
forall a. STM a -> IO a
atomically (STM PasswordConfig -> IO PasswordConfig)
-> STM PasswordConfig -> IO PasswordConfig
forall a b. (a -> b) -> a -> b
$ TVar PasswordConfig -> STM PasswordConfig
forall a. TVar a -> STM a
readTVar TVar PasswordConfig
passwordConfigTV
         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
<$> TVar AuthenticateConfig
-> RouteT AuthenticateURL (ReaderT [Text] m) JStat
forall (m :: * -> *).
MonadIO m =>
TVar AuthenticateConfig -> RouteT AuthenticateURL m JStat
usernamePasswordCtrl TVar AuthenticateConfig
authenticateConfigTV

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

initPassword :: PasswordConfig
             -> FilePath
             -> AcidState AuthenticateState
             -> TVar AuthenticateConfig
             -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword :: PasswordConfig
-> String
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword PasswordConfig
passwordConfig String
basePath AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV =
  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
     TVar PasswordConfig
passwordConfigTV <- STM (TVar PasswordConfig) -> IO (TVar PasswordConfig)
forall a. STM a -> IO a
atomically (STM (TVar PasswordConfig) -> IO (TVar PasswordConfig))
-> STM (TVar PasswordConfig) -> IO (TVar PasswordConfig)
forall a b. (a -> b) -> a -> b
$ PasswordConfig -> STM (TVar PasswordConfig)
forall a. a -> STM (TVar a)
newTVar PasswordConfig
passwordConfig
     TVar PasswordConfig
-> AcidState PasswordState
-> String
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword' TVar PasswordConfig
passwordConfigTV AcidState PasswordState
passwordState String
basePath AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV

initPassword' :: TVar PasswordConfig
              -> AcidState PasswordState
              -> FilePath
              -> AcidState AuthenticateState
              -> TVar AuthenticateConfig
              -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword' :: TVar PasswordConfig
-> AcidState PasswordState
-> String
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword' TVar PasswordConfig
passwordConfigTV AcidState PasswordState
passwordState String
basePath AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV =
     do 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
$
                   TVar PasswordConfig
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] n) Response
forall (m :: * -> *).
Happstack m =>
TVar PasswordConfig
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState PasswordState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Text] m) Response
routePassword TVar PasswordConfig
passwordConfigTV AcidState AuthenticateState
authenticateState TVar AuthenticateConfig
authenticateConfigTV 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO ()
shutdown, (AuthenticationMethod
passwordAuthenticationMethod, AuthenticationHandler
forall (n :: * -> *).
Happstack n =>
[Text] -> RouteT AuthenticateURL n Response
authenticationHandler), TVar AuthenticateConfig
-> RouteT AuthenticateURL (ServerPartT IO) JStat
forall (m :: * -> *).
MonadIO m =>
TVar AuthenticateConfig -> RouteT AuthenticateURL m JStat
usernamePasswordCtrl TVar AuthenticateConfig
authenticateConfigTV)