{-# 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 ())