1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
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 passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments =
case parseSegments fromPathSegments pathSegments of
(Left _) -> notFound $ toJSONError URLDecodeFailed
(Right url) ->
do authenticateConfig <- liftIO $ atomically $ readTVar authenticateConfigTV
passwordConfig <- liftIO $ atomically $ readTVar passwordConfigTV
case url of
Token -> token authenticateState authenticateConfig passwordState
Account mUrl -> toJSONResponse <$> account authenticateState passwordState authenticateConfig passwordConfig mUrl
(Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u)
return $ toResponse (html4StrictFrag, xml)
PasswordRequestReset -> toJSONResponse <$> passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState
PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig
UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl authenticateConfigTV
------------------------------------------------------------------------------
-- initPassword
------------------------------------------------------------------------------
initPassword :: PasswordConfig
-> FilePath
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword passwordConfig basePath authenticateState authenticateConfigTV =
do passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState
passwordConfigTV <- atomically $ newTVar passwordConfig
initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV
initPassword' :: TVar PasswordConfig
-> AcidState PasswordState
-> FilePath
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV =
do let shutdown = \normal ->
if normal
then createCheckpointAndClose passwordState
else closeAcidState passwordState
authenticationHandler pathSegments =
do langsOveride <- queryString $ lookTexts' "_LANG"
langs <- bestLanguage <$> acceptLanguage
mapRouteT (flip runReaderT (langsOveride ++ langs)) $
routePassword passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments
pure (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl authenticateConfigTV)
|
