{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-} module Happstack.Authenticate.Password.Partials where import Control.Category ((.), id) import Control.Lens ((^.)) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (MonadIO, lift) import Data.Acid (AcidState) import Data.Data (Data, Typeable) import Data.Monoid ((<>)) import Data.Text (Text) import Data.UserId (UserId) import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import HSP import Happstack.Server.HSP.HTML () import Language.Haskell.HSX.QQ (hsx) import Language.Javascript.JMacro import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken, tokenUser, userId) import Happstack.Authenticate.Password.Core (PasswordError(NotAuthenticated)) import Happstack.Authenticate.Password.URL (AccountURL(..), PasswordURL(..), nestPasswordURL) import Happstack.Authenticate.Password.PartialsURL (PartialURL(..)) import Happstack.Server (Happstack, unauthorized) import Happstack.Server.XMLGenT () import HSP.JMacro () import Prelude hiding ((.), id) import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage) import Web.Routes import Web.Routes.XMLGenT () import Web.Routes.TH (derivePathInfo) type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m)) type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) data PartialMsgs = UsernameMsg | EmailMsg | PasswordMsg | PasswordConfirmationMsg | SignUpMsg | SignInMsg | LogoutMsg | OldPasswordMsg | NewPasswordMsg | NewPasswordConfirmationMsg | ChangePasswordMsg | RequestPasswordResetMsg mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/password/partials" "en" instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where asChild msg = do lang <- ask asChild $ renderMessage HappstackAuthenticateI18N lang msg instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where asAttr (k := v) = do lang <- ask asAttr (k := renderMessage HappstackAuthenticateI18N lang v) routePartial :: (Functor m, Monad m, Happstack m) => AcidState AuthenticateState -> PartialURL -> Partial m XML routePartial authenticateState url = case url of LoginInline -> usernamePasswordForm True Login -> usernamePasswordForm False Logout -> logoutForm SignupPassword -> signupPasswordForm ChangePassword -> do mUser <- getToken authenticateState case mUser of Nothing -> unauthorized =<< [hsx|
<% show NotAuthenticated %>
|] -- FIXME: I18N (Just (token, _)) -> changePasswordForm (token ^. tokenUser ^. userId) RequestResetPasswordForm -> requestResetPasswordForm ResetPasswordForm -> resetPasswordForm signupPasswordForm :: (Functor m, Monad m) => Partial m XML signupPasswordForm = [hsx| |] usernamePasswordForm :: (Functor m, Monad m) => Bool -> Partial m XML usernamePasswordForm inline = [hsx| |] logoutForm :: (Functor m, MonadIO m) => Partial m XML logoutForm = [hsx| |] changePasswordForm :: (Functor m, MonadIO m) => UserId -> Partial m XML changePasswordForm userId = do url <- lift $ nestPasswordURL $ showURL (Account (Just (userId, Password))) let changePasswordFn = "changePassword('" <> url <> "')" [hsx| |] requestResetPasswordForm :: (Functor m, MonadIO m) => Partial m XML requestResetPasswordForm = do -- url <- lift $ nestPasswordURL $ showURL PasswordReset -- let changePasswordFn = "resetPassword('" <> url <> "')" [hsx|