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
|
{-# LANGUAGE OverloadedStrings #-}
module Happstack.Authenticate.OpenId.Route where
import Control.Applicative ((<$>))
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, readTVar)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.Trans (liftIO)
import Data.Acid (AcidState, closeAcidState, makeAcidic)
import Data.Acid.Advanced (query')
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.OpenId.Core (GetOpenIdRealm(..), OpenIdError(..), OpenIdState, initialOpenIdState, realm, token)
import Happstack.Authenticate.OpenId.Controllers (openIdCtrl)
import Happstack.Authenticate.OpenId.URL (OpenIdURL(..), openIdAuthenticationMethod, nestOpenIdURL)
import Happstack.Authenticate.OpenId.Partials (routePartial)
import Happstack.Server (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse, seeOther)
import Happstack.Server.JMacro ()
import HSP (unXMLGenT)
import HSP.HTML4 (html4StrictFrag)
import Language.Javascript.JMacro (JStat)
import Network.HTTP.Conduit (newManager, tlsManagerSettings)
import System.FilePath (combine)
import Text.Shakespeare.I18N (Lang)
import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl)
import Web.Routes (PathInfo(..), RouteT(..), mapRouteT, nestURL, parseSegments, showURL)
------------------------------------------------------------------------------
-- routeOpenId
------------------------------------------------------------------------------
routeOpenId :: (Happstack m) =>
AcidState AuthenticateState
-> TVar AuthenticateConfig
-> AcidState OpenIdState
-> [Text]
-> RouteT AuthenticateURL (ReaderT [Lang] m) Response
routeOpenId authenticateState authenticateConfigTV openIdState pathSegments =
case parseSegments fromPathSegments pathSegments of
(Left _) -> notFound $ toJSONError URLDecodeFailed
(Right url) ->
do case url of
(Partial u) ->
do xml <- unXMLGenT (routePartial authenticateState openIdState u)
ok $ toResponse (html4StrictFrag, xml)
(BeginDance providerURL) ->
do returnURL <- nestOpenIdURL $ showURL ReturnTo
realm <- query' openIdState GetOpenIdRealm
forwardURL <- liftIO $ do manager <- newManager tlsManagerSettings
getForwardUrl providerURL returnURL realm [] manager -- [("Email", "http://schema.openid.net/contact/email")]
seeOther forwardURL (toResponse ())
ReturnTo ->
do authenticateConfig <- liftIO $ atomically $ readTVar authenticateConfigTV
token authenticateState authenticateConfig openIdState
Realm -> realm authenticateState openIdState
------------------------------------------------------------------------------
-- initOpenId
------------------------------------------------------------------------------
initOpenId :: FilePath
-> AcidState AuthenticateState
-> TVar AuthenticateConfig
-> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId basePath authenticateState authenticateConfigTV =
do openIdState <- openLocalStateFrom (combine basePath "openId") initialOpenIdState
let shutdown = \normal ->
if normal
then createCheckpointAndClose openIdState
else closeAcidState openIdState
authenticationHandler pathSegments =
do langsOveride <- queryString $ lookTexts' "_LANG"
langs <- bestLanguage <$> acceptLanguage
mapRouteT (flip runReaderT (langsOveride ++ langs)) $
routeOpenId authenticateState authenticateConfigTV openIdState pathSegments
return (shutdown, (openIdAuthenticationMethod, authenticationHandler), openIdCtrl authenticateState openIdState)
|
