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.Routes
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
(Just authId) ->
do update' acid (AddAuthMethod (AuthIdentifier identifier) authId)
seeOther (T.unpack onAuthURL) (toResponse ())
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)
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
-> Maybe Text
-> Text
-> 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)
handleOpenId :: (Alternative m, Happstack m, MonadRoute m, URL m ~ OpenIdURL) =>
AcidState AuthState
-> Maybe Text
-> Text
-> OpenIdURL
-> 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
-> 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 ())