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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
{-# LANGUAGE GADTs, TypeFamilies, ViewPatterns, RecordWildCards #-}
module Happstack.Auth.Core.AuthParts where
import Control.Applicative (Alternative)
import Control.Monad.Trans (liftIO)
import Data.Acid (AcidState)
import Data.Acid.Advanced (query', update')
import Data.Aeson (Value(..))
import qualified Data.HashMap.Lazy as HashMap
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Facebook (Credentials, AccessToken(UserAccessToken), getUserAccessTokenStep1, getUserAccessTokenStep2, runFacebookT)
import Happstack.Server (Happstack, Response, lookPairsBS, lookText, seeOther, toResponse, internalServerError)
import Happstack.Auth.Core.Auth
import Happstack.Auth.Core.AuthURL
import Network.HTTP.Conduit (withManager)
import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl)
-- import Web.Authenticate.Facebook (Facebook(..), getAccessToken, getGraphData)
-- import qualified Web.Authenticate.Facebook as Facebook
import Web.Routes
-- this verifies the identifier
-- and sets authToken cookie
-- if the identifier was not associated with an AuthId, then a new AuthId will be created and associated with it.
openIdPage :: (Alternative m, Happstack m) =>
AcidState AuthState
-> AuthMode
-> Text
-> m Response
openIdPage acid LoginMode onAuthURL =
do identifier <- getIdentifier
identifierAddAuthIdsCookie acid identifier
seeOther (T.unpack onAuthURL) (toResponse ())
openIdPage acid AddIdentifierMode onAuthURL =
do identifier <- getIdentifier
mAuthId <- getAuthId acid
case mAuthId of
Nothing -> undefined -- FIXME
(Just authId) ->
do update' acid (AddAuthMethod (AuthIdentifier identifier) authId)
seeOther (T.unpack onAuthURL) (toResponse ())
-- this get's the identifier the openid provider provides. It is our only chance to capture the Identifier. So, before we send a Response we need to have some sort of cookie set that identifies the user. We can not just put the identifier in the cookie because we don't want some one to fake it.
getIdentifier :: (Happstack m) => m Identifier
getIdentifier =
do pairs' <- lookPairsBS
let pairs = mapMaybe (\(k, ev) -> case ev of (Left _) -> Nothing ; (Right v) -> Just (T.pack k, TL.toStrict $ TL.decodeUtf8 v)) pairs'
oir <- liftIO $ withManager $ authenticateClaimed pairs
return (oirOpLocal oir)
-- calling this will log you in as 1 or more AuthIds
-- problem.. if the Identifier is not associated with any Auths, then we are in trouble, because the identifier will be 'lost'.
-- so, if there are no AuthIds associated with the identifier, we create one.
--
-- we have another problem though.. we want to allow a user to specify a prefered AuthId. But that preference needs to be linked to a specific Identifier ?
identifierAddAuthIdsCookie :: (Happstack m) => AcidState AuthState -> Identifier -> m (Maybe AuthId)
identifierAddAuthIdsCookie acid identifier =
do authId <-
do authIds <- query' acid (IdentifierAuthIds identifier)
case Set.size authIds of
1 -> return $ (Just $ head $ Set.toList $ authIds)
n -> return $ Nothing
addAuthCookie acid authId (AuthIdentifier identifier)
return authId
facebookAddAuthIdsCookie :: (Happstack m) => AcidState AuthState -> FacebookId -> m (Maybe AuthId)
facebookAddAuthIdsCookie acid facebookId =
do authId <-
do authIds <- query' acid (FacebookAuthIds facebookId)
case Set.size authIds of
1 -> return $ (Just $ head $ Set.toList $ authIds)
n -> return $ Nothing
addAuthCookie acid authId (AuthFacebook facebookId)
return authId
connect :: (Happstack m, MonadRoute m, URL m ~ OpenIdURL) =>
AuthMode -- ^ authentication mode
-> Maybe Text -- ^ realm
-> Text -- ^ openid url
-> m Response
connect authMode realm url =
do openIdUrl <- showURL (O_OpenId authMode)
gotoURL <- liftIO $ withManager $ getForwardUrl url openIdUrl realm []
seeOther (T.unpack gotoURL) (toResponse gotoURL)
-- type ProviderPage m p = (OpenIdURL p) -> AuthMode -> m Response
handleOpenId :: (Alternative m, Happstack m, MonadRoute m, URL m ~ OpenIdURL) =>
AcidState AuthState
-> Maybe Text -- ^ realm
-> Text -- ^ onAuthURL
-> OpenIdURL -- ^ this url
-> m Response
handleOpenId acid realm onAuthURL url =
case url of
(O_OpenId authMode) -> openIdPage acid authMode onAuthURL
(O_Connect authMode) ->
do url <- lookText "url"
connect authMode realm (TL.toStrict url)
facebookPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => Credentials -> AuthMode -> m Response
facebookPage credentials authMode =
do redirectUri <- showURL (A_FacebookRedirect authMode)
uri <- liftIO $ withManager $ \m ->
runFacebookT credentials m $
getUserAccessTokenStep1 redirectUri []
seeOther (T.unpack uri) (toResponse ())
facebookRedirectPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>
AcidState AuthState
-> Credentials
-> Text -- ^ onAuthURL
-> AuthMode
-> m Response
facebookRedirectPage acidAuth credentials onAuthURL authMode =
do redirectUri <- showURL (A_FacebookRedirect authMode)
userAccessToken <-
liftIO $ withManager $ \m ->
runFacebookT credentials m $
getUserAccessTokenStep2 redirectUri []
case (authMode, userAccessToken) of
(LoginMode, UserAccessToken facebookId _ _) ->
do facebookAddAuthIdsCookie acidAuth (FacebookId facebookId)
seeOther (T.unpack onAuthURL) (toResponse ())
(AddIdentifierMode, UserAccessToken facebookId _ _) ->
do mAuthId <- getAuthId acidAuth
case mAuthId of
Nothing -> internalServerError $ toResponse $ "Could not add new authentication method because the user is not logged in."
(Just authId) ->
do update' acidAuth (AddAuthMethod (AuthFacebook (FacebookId facebookId)) authId)
seeOther (T.unpack onAuthURL) (toResponse ())
|
