happstack-authenticate (empty) → 0.9.2
raw patch · 12 files changed
+1733/−0 lines, 12 filesdep +QuickCheckdep +acid-statedep +aesonsetup-changed
Dependencies added: QuickCheck, acid-state, aeson, authenticate, base, blaze-html, bytestring, containers, fb, happstack-server, http-conduit, http-types, ixset, mtl, pwstore-purehaskell, reform, reform-blaze, reform-happstack, safecopy, text, time, unordered-containers, web-routes, web-routes-happstack
Files
- Happstack/Auth.hs +21/−0
- Happstack/Auth/Blaze/Templates.hs +588/−0
- Happstack/Auth/Core/Auth.hs +467/−0
- Happstack/Auth/Core/AuthParts.hs +137/−0
- Happstack/Auth/Core/AuthProfileURL.hs +30/−0
- Happstack/Auth/Core/AuthURL.hs +152/−0
- Happstack/Auth/Core/Profile.hs +130/−0
- Happstack/Auth/Core/ProfileParts.hs +76/−0
- Happstack/Auth/Core/ProfileURL.hs +50/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- happstack-authenticate.cabal +50/−0
+ Happstack/Auth.hs view
@@ -0,0 +1,21 @@+module Happstack.Auth + ( UserId(..)+ , AuthState(..)+ , ProfileState(..)+ , AuthProfileURL(..)+ , AuthURL(..)+ , ProfileURL(..)+ , getUserId+ , authProfileHandler+ , handleAuth+ , handleProfile+ , handleAuthProfile+ ) where++import Happstack.Auth.Core.Profile (UserId(..), getUserId)+import Happstack.Auth.Core.Auth (AuthState(..))+import Happstack.Auth.Core.AuthURL (AuthURL(..))+import Happstack.Auth.Core.Profile (ProfileState(..))+import Happstack.Auth.Core.ProfileURL (ProfileURL(..))+import Happstack.Auth.Core.AuthProfileURL (AuthProfileURL(..))+import Happstack.Auth.Blaze.Templates (authProfileHandler, handleAuth, handleProfile, handleAuthProfile)
+ Happstack/Auth/Blaze/Templates.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE FlexibleInstances, RankNTypes, TypeFamilies, OverloadedStrings #-}+-- | This modules provides templates and routing functions which can+-- be used to integrate authentication into your site.+--+-- In most cases, you only need to call the 'handleAuth' and+-- 'hanldeProfile' functions. The other functions are exported in case+-- you wish to create your own alternatives to 'handleAuth' \/+-- 'handleProfile'+--+module Happstack.Auth.Blaze.Templates+ ( -- * handlers+ handleAuth+ , handleProfile+ , handleAuthProfile+ , authProfileHandler+ -- * page functions+ , addAuthPage+ , authPicker+ , createAccountPage+ , googlePage+ , genericOpenIdPage+ , yahooPage+ , liveJournalPage+ , liveJournalForm+ , myspacePage+ , localLoginPage+ , newAccountForm+ , personalityPicker+ , providerPage+ , loginPage+ , logoutPage+ , changePasswordPage+ , changePasswordForm+ ) where++import Control.Applicative (Alternative, (<*>), (<$>), (<*), (*>), optional)+import Control.Monad (replicateM, mplus, mzero)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Acid (AcidState)+import Data.Acid.Advanced (query', update')+import Data.Maybe (mapMaybe)+import Data.Monoid (mempty)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (getCurrentTime)+import Facebook (Credentials)+import Happstack.Auth.Core.Auth+import Happstack.Auth.Core.AuthParts+import Happstack.Auth.Core.AuthURL+import Happstack.Auth.Core.ProfileURL+import Happstack.Auth.Core.Profile+import Happstack.Auth.Core.ProfileParts+import Happstack.Auth.Core.AuthProfileURL (AuthProfileURL(..))+import Happstack.Server (Happstack, Input, Response, internalServerError, ok, seeOther, toResponse, unauthorized)+import Text.Blaze.Html5 as H hiding (fieldset, ol, li, label, head)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes as A hiding (label)+import Text.Reform+import Text.Reform.Blaze.Text as R+import Text.Reform.Happstack as R+import Web.Authenticate.OpenId (Identifier, authenticate, getForwardUrl)+import Web.Authenticate.OpenId.Providers (google, yahoo, livejournal, myspace)+import Web.Routes (RouteT(..), Site(..), PathInfo(..), MonadRoute(askRouteFn), parseSegments, showURL, showURLParams, nestURL, liftRouteT, URL)+import Web.Routes.Happstack (implSite_, seeOtherURL)++smap :: (String -> String) -> Text -> Text+smap f = Text.pack . f . Text.unpack++data AuthTemplateError+ = ATECommon (CommonFormError [Input])+ | UPE UserPassError+ | MinLength Int+ | PasswordMismatch++instance FormError AuthTemplateError where+ type ErrorInputType AuthTemplateError = [Input]+ commonFormError = ATECommon++instance ToMarkup (CommonFormError [Input]) where+ toMarkup e = toMarkup $ show e++instance ToMarkup AuthTemplateError where+ toMarkup (ATECommon e) = toHtml $ e+ toMarkup (UPE e) = toHtml $ userPassErrorString e+ toMarkup (MinLength n) = toHtml $ "mimimum length: " ++ show n+ toMarkup PasswordMismatch = "Passwords do not match."++type AuthForm m a = Form m [Input] AuthTemplateError Html () a++logoutPage :: (MonadRoute m, URL m ~ AuthURL, Alternative m, Happstack m) => AcidState AuthState -> m Html+logoutPage authStateH =+ do deleteAuthCookie authStateH+ url <- H.toValue <$> showURL A_Login+ return $ H.div ! A.id "happstack-authenticate" $+ p $ do "You are now logged out. Click "+ a ! href url $ "here"+ " to log in again."++loginPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html+loginPage mFacebook =+ do googleURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Google)+ yahooURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Yahoo)+ liveJournalURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode LiveJournal)+ myspaceURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Myspace)+ genericURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Generic)+ localURL <- H.toValue <$> showURL A_Local+ facebookURL <- H.toValue <$> showURL (A_Facebook LoginMode)+ return $ H.div ! A.id "happstack-authenticate" $+ H.ol $ do+ H.li $ (a ! href googleURL $ "Login") >> " with your Google account"+ H.li $ (a ! href yahooURL $ "Login") >> " with your Yahoo account"+ H.li $ (a ! href liveJournalURL $ "Login") >> " with your Live Journal account"+ H.li $ (a ! href myspaceURL $ "Login") >> " with your Myspace account"+ H.li $ (a ! href genericURL $ "Login") >> " with your OpenId account"+ H.li $ (a ! href localURL $ "Login") >> " with a username and password"+ case mFacebook of+ (Just _) -> H.li $ (a ! href facebookURL $ "Login") >> " with your Facebook account"+ Nothing -> return ()++addAuthPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html+addAuthPage mFacebook =+ do googleURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Google)+ yahooURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Yahoo)+ liveJournalURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode LiveJournal)+ myspaceURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Myspace)+ genericURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Generic)+ facebookURL <- H.toValue <$> showURL (A_Facebook AddIdentifierMode)+ return $ H.div ! A.id "happstack-authenticate" $+ H.ol $ do+ H.li $ (a ! href googleURL $ "Add") >> " your Google account"+ H.li $ (a ! href yahooURL $ "Add") >> " your Yahoo account"+ H.li $ (a ! href liveJournalURL $ "Add") >> " your Live Journal account"+ H.li $ (a ! href myspaceURL $ "Add") >> " your Myspace account"+ H.li $ (a ! href genericURL $ "Add") >> " your OpenId account"+ case mFacebook of+ (Just _) -> H.li $ (a ! href facebookURL $ "Add") >> " your Facebook account"+ Nothing -> return ()++authPicker :: (MonadRoute m, URL m ~ ProfileURL, Happstack m) => Set AuthId -> m Html+authPicker authIds =+ do auths <- mapM auth (Set.toList authIds)+ return $ H.div ! A.id "happstack-authenticate" $+ H.ul $ sequence_ auths+ where+ auth authId =+ do url <- H.toValue <$> showURL (P_SetAuthId authId)+ return $ H.li $ a ! href url $ (H.toHtml $ show authId) -- FIXME: give a more informative view.++personalityPicker :: (MonadRoute m, URL m ~ ProfileURL, Happstack m) =>+ Set Profile+ -> m Html+personalityPicker profiles =+ do personalities <- mapM personality (Set.toList profiles)+ return $ H.div ! A.id "happstack-authenticate" $+ H.ul $ sequence_ personalities+ where+ personality profile =+ do url <- H.toValue <$> showURL (P_SetPersonality (userId profile))+ return $ H.li $ a ! href url $ (H.toHtml $ nickName profile)++providerPage :: (URL m ~ AuthURL, Happstack m, MonadRoute m) =>+ (String -> Html -> Html -> m Response)+ -> OpenIdProvider+ -> AuthURL+ -> AuthMode+ -> m Response+providerPage appTemplate provider =+ case provider of+ Google -> googlePage+ Yahoo -> yahooPage+ LiveJournal -> liveJournalPage appTemplate+ Myspace -> myspacePage appTemplate+ Generic -> genericOpenIdPage appTemplate++googlePage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ AuthURL+ -> AuthMode+ -> m Response+googlePage _here authMode =+ do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ Text.pack google)]+ seeOther (Text.unpack u) (toResponse ())++yahooPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ AuthURL+ -> AuthMode+ -> m Response+yahooPage _here authMode =+ do u <- showURLParams (A_OpenId (O_Connect authMode)) [(Text.pack "url", Just $ Text.pack yahoo)]+ seeOther (Text.unpack u) (toResponse ())++myspacePage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ (String -> Html -> Html -> m Response)+ -> AuthURL+ -> AuthMode+ -> m Response+myspacePage appTemplate here authMode =+ do actionURL <- showURL here+ e <- happstackEitherForm (R.form actionURL) "msp" usernameForm+ case e of+ (Left formHtml) ->+ do r <- appTemplate "Login via Myspace" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 "Login using your myspace account"+ p "Enter your Myspace account name to connect."+ formHtml+ ok r+ (Right username) ->+ do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ smap myspace username)]+ seeOther (Text.unpack u) (toResponse ())++ where+ usernameForm :: (Functor m, Monad m) => AuthForm m Text+ usernameForm =+ label ("http://www.myspace.com/" :: String) ++> inputText mempty <* (mapView (\html -> html ! A.class_ "submit") $ inputSubmit "Login")+++liveJournalPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ (String -> Html -> Html -> m Response)+ -> AuthURL+ -> AuthMode+ -> m Response+liveJournalPage appTemplate here authMode =+ do actionURL <- showURL here+ e <- happstackEitherForm (R.form actionURL) "ljp" liveJournalForm+ case e of+ (Left formHtml) ->+ do r <- appTemplate "Login via LiveJournal" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 $ "Login using your Live Journal account"+ p $ "Enter your livejournal account name to connect. You may be prompted to log into your livejournal account and to confirm the login."+ formHtml+ ok r+ (Right username) ->+ do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ smap livejournal username)]+ seeOther (Text.unpack u) (toResponse ())++liveJournalForm :: (Functor m, Monad m) => AuthForm m Text+liveJournalForm =+ label ("http://" :: String) ++> inputText mempty <++ label (".livejournal.com/" :: String) <*+ (mapView (\html -> html ! A.class_ "submit") $ inputSubmit "Connect")++genericOpenIdPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ (String -> Html -> Html -> m Response)+ -> AuthURL+ -> AuthMode+ -> m Response+genericOpenIdPage appTemplate here authMode =+ do actionURL <- showURL here+ e <- happstackEitherForm (R.form actionURL) "oiu" openIdURLForm+ case e of+ (Left formHtml) ->+ do r <- appTemplate "Login via Generic OpenId" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 "Login using your OpenId account"+ formHtml+ ok r+ (Right url) ->+ do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just url)]+ seeOther (Text.unpack u) (toResponse ())+ where+ openIdURLForm :: (Functor m, Monad m) => AuthForm m Text+ openIdURLForm =+ label ("Your OpenId url: " :: String) ++> inputText mempty <* inputSubmit "Connect"++-- | Function which takes care of all 'AuthURL' routes.+--+-- The caller provides a page template function which will be used to+-- render pages. The provided page template function takes three+-- arguments:+--+-- > String -- ^ string to use in the <title> tag+-- > -> Html -- ^ extra headers to add to the <head> tag+-- > -> Html -- ^ contents to stick in the <body> tag+handleAuth :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ AcidState AuthState -- ^ database handle for 'AuthState'+ -> (String -> Html -> Html -> m Response) -- ^ page template function+ -> Maybe Credentials -- ^ config information for facebook connect+ -> Maybe Text -- ^ authentication realm+ -> Text -- ^ URL to redirect to after succesful authentication+ -> AuthURL -- ^ url to route+ -> m Response+handleAuth authStateH appTemplate mFacebook realm onAuthURL url =+ case url of+ A_Login -> appTemplate "Login" mempty =<< loginPage mFacebook+ A_AddAuth -> appTemplate "Add Auth" mempty =<< addAuthPage mFacebook+ A_Logout -> appTemplate "Logout" mempty =<< logoutPage authStateH++ A_Local -> localLoginPage authStateH appTemplate url onAuthURL+ A_CreateAccount -> createAccountPage authStateH appTemplate onAuthURL url+ A_ChangePassword -> changePasswordPage authStateH appTemplate url++ (A_OpenId oidURL) -> do showFn <- askRouteFn+ unRouteT (nestURL A_OpenId $ handleOpenId authStateH realm onAuthURL oidURL) showFn++ (A_OpenIdProvider authMode provider)+ -> providerPage appTemplate provider url authMode++ (A_Facebook authMode)+ -> case mFacebook of+ Nothing -> do resp <- appTemplate "Facebook authentication not configured." mempty $+ H.div ! A.id "happstack-authenticate" $+ p "Facebook authentication not configured."+ internalServerError resp+ (Just facebook) -> facebookPage facebook authMode++ (A_FacebookRedirect authMode)+ -> case mFacebook of+ Nothing -> do resp <- appTemplate "Facebook authentication not configured." mempty $+ H.div ! A.id "happstack-authenticate" $+ p "Facebook authentication not configured."+ internalServerError resp+ (Just facebook) -> facebookRedirectPage authStateH facebook onAuthURL authMode++-- | Function which takes care of all 'ProfileURL' routes.+--+-- The caller provides a page template function which will be used to+-- render pages. The provided page template function takes three+-- arguments:+--+-- > String -- ^ string to use in the <title> tag+-- > -> Html -- ^ extra headers to add to the <head> tag+-- > -> Html -- ^ contents to stick in the <body> tag+handleProfile :: (Happstack m, Alternative m, MonadRoute m, URL m ~ ProfileURL) =>+ AcidState AuthState -- ^ database handle for 'AuthState'+ -> AcidState ProfileState -- ^ database handle for 'ProfileState'+ -> (String -> Html -> Html -> m Response) -- ^ page template function+ -> Text -- ^ URL to redirect to after successfully picking an identity+ -> ProfileURL -- ^ URL to route+ -> m Response+handleProfile authStateH profileStateH appTemplate postPickedURL url =+ case url of+ P_PickProfile ->+ do r <- pickProfile authStateH profileStateH+ case r of+ (Picked {}) ->+ seeOther (Text.unpack postPickedURL) (toResponse postPickedURL)++ (PickPersonality profiles) ->+ appTemplate "Pick Personality" mempty =<< (personalityPicker profiles)++ (PickAuthId authIds) ->+ appTemplate "Pick Auth" mempty =<< (authPicker authIds)++ (P_SetAuthId authId) ->+ do b <- setAuthIdPage authStateH authId+ if b+ then seeOther ("/" :: String) (toResponse ()) -- FIXME: don't hardcode destination+ else do resp <- appTemplate "Unauthorized" mempty $+ H.div ! A.id "happstack-authenticate" $+ p $ do " Attempted to set AuthId to "+ toHtml $ show $ unAuthId authId+ ", but failed because the Identifier is not associated with that AuthId."+ unauthorized resp+++-- handleAuthProfile :: (Happstack m, Alternative m, MonadRoute m, URL m ~ AuthProfileURL) =>++authProfileSite :: (Happstack m) =>+ AcidState AuthState+ -> AcidState ProfileState+ -> (String -> Html -> Html -> m Response)+ -> Maybe Credentials+ -> Maybe Text+ -> Text+ -> Site AuthProfileURL (m Response)+authProfileSite acidAuth acidProfile appTemplate mFacebook realm postPickedURL+ = Site { handleSite = \f u -> unRouteT (handleAuthProfileRouteT acidAuth acidProfile appTemplate mFacebook realm postPickedURL u) f+ , formatPathSegments = \u -> (toPathSegments u, [])+ , parsePathSegments = parseSegments fromPathSegments+ }++authProfileHandler :: (Happstack m) =>+ Text+ -> Text+ -> AcidState AuthState+ -> AcidState ProfileState+ -> (String -> Html -> Html -> m Response)+ -> Maybe Credentials+ -> Maybe Text+ -> Text+ -> m Response+authProfileHandler baseURI pathPrefix acidAuth acidProfile appTemplate mFacebook realm postPickedURL =+ do r <- implSite_ baseURI pathPrefix (authProfileSite acidAuth acidProfile appTemplate mFacebook realm postPickedURL)+ case r of+ (Left e) -> mzero+ (Right r) -> return r++handleAuthProfile :: forall m. (Happstack m, MonadRoute m, URL m ~ AuthProfileURL) =>+ AcidState AuthState+ -> AcidState ProfileState+ -> (String -> Html -> Html -> m Response)+ -> Maybe Credentials+ -> Maybe Text+ -> Text+ -> AuthProfileURL+ -> m Response+handleAuthProfile authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url =+ do routeFn <- askRouteFn+ unRouteT (handleAuthProfileRouteT authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url) routeFn++handleAuthProfileRouteT :: forall m. (Happstack m) =>+ AcidState AuthState+ -> AcidState ProfileState+ -> (String -> Html -> Html -> m Response)+ -> Maybe Credentials+ -> Maybe Text+ -> Text+ -> AuthProfileURL+ -> RouteT AuthProfileURL m Response+handleAuthProfileRouteT authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url =+ case url of+ (AuthURL authURL) ->+ do onAuthURL <- showURL (ProfileURL P_PickProfile)+ let template t h b = liftRouteT (appTemplate t h b)+ nestURL AuthURL $ handleAuth authStateH template mFacebook mRealm onAuthURL authURL+ (ProfileURL profileURL) ->+ do let template t h b = liftRouteT (appTemplate t h b)+ nestURL ProfileURL $ handleProfile authStateH profileStateH template postPickedURL profileURL++localLoginPage authStateH appTemplate here onAuthURL =+ do actionURL <- showURL here+ createURL <- showURL A_CreateAccount+ e <- happstackEitherForm (R.form actionURL) "lf" (loginForm createURL)+ case e of+ (Left errorForm) ->+ do r <- appTemplate "Login" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 "Login"+ errorForm+ ok r+ (Right userPassId) ->+ do authId <- do authIds <- query' authStateH (UserPassIdAuthIds userPassId)+ case Set.size authIds of+ 1 -> return (Just $ head $ Set.toList $ authIds)+ n -> return Nothing+ addAuthCookie authStateH authId (AuthUserPassId userPassId)+ seeOther (Text.unpack onAuthURL) (toResponse ())++ where+ loginForm createURL =+ R.fieldset $+ (errorList ++>+ R.ol (((,) <$> (R.li $ errorList ++> label ("username: " :: String) ++> inputText mempty)+ <*> (R.li $ errorList ++> label ("password: " :: String) ++> inputPassword)+ <* login) `transformEitherM` checkAuth)+ <* (create createURL))++ create createURL = view $ p $ do "or "+ H.a ! href (toValue createURL) $ "create a new account"+ login = li $ mapView (\html -> html ! A.class_ "submit") (inputSubmit "Login")++ checkAuth :: (MonadIO m) => (Text, Text) -> m (Either AuthTemplateError UserPassId)+ checkAuth (username, password) =+ do r <- query' authStateH (CheckUserPass username password)+ case r of+ (Left e) -> return (Left $ UPE e)+ (Right userPassId) -> return (Right userPassId)++createAccountPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AcidState AuthState -> (String -> Html -> Html -> m Response) -> Text -> AuthURL -> m Response+createAccountPage authStateH appTemplate onAuthURL here =+ do actionURL <- showURL here+ e <- happstackEitherForm (R.form actionURL) "naf" (newAccountForm authStateH)+ case e of++ (Left formHtml) ->+ do r <- appTemplate "Create New Account" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 "Create an account"+ formHtml+ ok r++ (Right (authId, userPassId)) ->+ do addAuthCookie authStateH (Just authId) (AuthUserPassId userPassId)+ seeOther (Text.unpack onAuthURL) (toResponse ())++newAccountForm :: (Functor v, MonadIO v) => AcidState AuthState -> AuthForm v (AuthId, UserPassId)+newAccountForm authStateH =+ (R.fieldset+ (errorList ++>+ (R.ol $ (((,) <$> username <*> password <* submitButton)))+ `transformEitherM`+ createAccount))+ where+ submitButton = R.li $ (mapView (\html -> html ! A.class_ "submit") $ inputSubmit "Create Account")+ username = R.li $ errorList ++> ((label ("username: " :: String) ++> inputText mempty) `transformEither` (minLength 1))+ password1 = R.li $ label ("password: " :: String) ++> inputPassword+ password2 = R.li $ label ("confirm password: " :: String) ++> inputPassword++ password =+ errorList ++> (((,) <$> password1 <*> password2) `transformEither` samePassword) `transformEither` minLength 6++ samePassword (p1, p2) =+ if p1 /= p2+ then (Left $ PasswordMismatch)+ else (Right p1)++ createAccount (username, password) =+ do passHash <- liftIO $ mkHashedPass password+ r <- update' authStateH $ CreateUserPass (UserName username) passHash+ -- fixme: race condition+ case r of+ (Left e) -> return (Left $ UPE e)+ (Right userPass) ->+ do authId <- update' authStateH (NewAuthMethod (AuthUserPassId (upId userPass)))+ return (Right (authId, upId userPass))++changePasswordPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) =>+ AcidState AuthState -> (String -> Html -> Html -> m Response) -> AuthURL -> m Response+changePasswordPage authStateH appTemplate here =+ do actionURL <- showURL here+ mAuthToken <- getAuthToken authStateH+ case mAuthToken of+ Nothing -> seeOtherURL A_Login+ (Just authToken) ->+ case tokenAuthMethod authToken of+ (AuthUserPassId userPassId) ->+ do mUserPass <- query' authStateH (AskUserPass userPassId)+ case mUserPass of+ Nothing ->+ do resp <- appTemplate "Invalid UserPassId" mempty $ do H.div ! A.id "happstack-authenticate" $+ p $ do "Invalid UserPassId"+ toHtml $ show $ unUserPassId userPassId+ internalServerError resp+ (Just userPass) ->+ do e <- happstackEitherForm (R.form actionURL) "cpf" (changePasswordForm authStateH userPass)+ case e of+ (Left formHtml) ->+ do r <- appTemplate "Change Passowrd" mempty $+ H.div ! A.id "happstack-authenticate" $+ do h1 $ do "Change password for "+ toHtml $ unUserName $ upName userPass+ formHtml+ ok r+ (Right passwd) ->+ do hashedPass <- liftIO $ mkHashedPass passwd+ r <- update' authStateH (SetPassword userPassId hashedPass)+ case r of+ (Just e) ->+ do resp <- appTemplate "Change Password Failed" mempty $+ H.div ! A.id "happstack-authenticate" $+ p $ toHtml (userPassErrorString e)+ internalServerError resp+ Nothing ->+ do resp <- appTemplate "Password Changed!" mempty $+ H.div ! A.id "happstack-authenticate" $+ p $ "Your password has been updated."+ ok resp++changePasswordForm :: (Functor v, MonadIO v) => AcidState AuthState -> UserPass -> AuthForm v Text+changePasswordForm authStateH userPass =+ fieldset $ ol $ oldPassword *> newPassword <* changeBtn+ where+ -- form elements+ oldPassword =+ errorList ++>+ (li $ label ("old password: " :: String) ++> inputPassword `transformEitherM` checkAuth)++ checkAuth password =+ do r <- query' authStateH (CheckUserPass (unUserName $ upName userPass) password)+ case r of+ (Left e) -> return (Left $ UPE e)+ (Right _) -> return (Right password)++ password1, password2 :: (Functor v, Monad v) => AuthForm v Text+ password1 = li $ label ("new password: " :: String) ++> inputPassword+ password2 = li $ label ("new confirm password: " :: String) ++> inputPassword++ newPassword :: (Functor v, Monad v) => AuthForm v Text+ newPassword =+ errorList ++>+ (((((,) <$> password1 <*> password2)) `transformEither` samePassword) `transformEither` minLength 6)++ samePassword :: (Text, Text) -> Either AuthTemplateError Text+ samePassword (p1, p2) =+ if p1 /= p2+ then (Left $ PasswordMismatch)+ else (Right p1)++ changeBtn :: (Functor v, Monad v) => AuthForm v (Maybe Text)+ changeBtn = li $ mapView (\html -> html ! A.class_ "submit") $ inputSubmit "change"++minLength :: Int -> Text -> Either AuthTemplateError Text+minLength n s =+ if Text.length s >= n+ then (Right s)+ else (Left $ MinLength n)
+ Happstack/Auth/Core/Auth.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable,+ FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances, TypeOperators, RecordWildCards+ #-}+module Happstack.Auth.Core.Auth+ ( UserPass(..)+ , UserPassId(..)+ , UserName(..)+ , UserPassError(..)+ , userPassErrorString+ , SetUserName(..)+ , AuthState(..)+ , initialAuthState+ , AuthToken(..)+ , AuthId(..)+ , FacebookId(..)+ , AuthMethod(..)+ , AuthMethod_v1(..)+ , AuthMap(..)+ , HashedPass(..)+ , mkHashedPass+ , genAuthToken+ , AskUserPass(..)+ , CheckUserPass(..)+ , CreateUserPass(..)+ , SetPassword(..)+ , AddAuthToken(..)+ , AskAuthToken(..)+ , UpdateAuthToken(..)+ , DeleteAuthToken(..)+ , AuthTokenAuthId(..)+ , GenAuthId(..)+ , AddAuthMethod(..)+ , NewAuthMethod(..)+ , RemoveAuthIdentifier(..)+ , IdentifierAuthIds(..)+ , FacebookAuthIds(..)+ , AddAuthUserPassId(..)+ , RemoveAuthUserPassId(..)+ , UserPassIdAuthIds(..)+ , AskAuthState(..)+ , addAuthCookie+ , deleteAuthCookie+ , getAuthId+ , getAuthToken+ ) where++import Control.Applicative (Alternative, (<$>), optional)+import Control.Monad (replicateM)+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)+import Control.Monad.Trans (MonadIO(..))+import Crypto.PasswordStore+import Data.Acid+import Data.Acid.Advanced (query', update')+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Data (Data, Typeable)+import qualified Data.IxSet as IxSet+import Data.IxSet (IxSet, (@=), inferIxSet, noCalcs, getOne, updateIx)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.SafeCopy -- (base, deriveSafeCopy)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime,)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Text (Text)+import Network.HTTP.Types (Ascii)+import Web.Authenticate.OpenId (Identifier)+import Web.Routes (PathInfo(..))+import Happstack.Server (CookieLife(..), Happstack, addCookie, expireCookie, lookCookieValue, mkCookie)++newtype AuthId = AuthId { unAuthId :: Integer }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''AuthId)++instance PathInfo AuthId where+ toPathSegments (AuthId i) = toPathSegments i+ fromPathSegments = AuthId <$> fromPathSegments++succAuthId :: AuthId -> AuthId+succAuthId (AuthId i) = AuthId (succ i)++-- * UserPass++newtype HashedPass = HashedPass ByteString+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''HashedPass)++newtype UserName = UserName { unUserName :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''UserName)++newtype UserPassId = UserPassId { unUserPassId :: Integer }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''UserPassId)++succUserPassId :: UserPassId -> UserPassId+succUserPassId (UserPassId i) = UserPassId (succ i)++data UserPass+ = UserPass { upName :: UserName+ , upPassword :: HashedPass+ , upId :: UserPassId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''UserPass)++$(inferIxSet "UserPasses" ''UserPass 'noCalcs [''UserName, ''HashedPass, ''AuthId, ''UserPassId])++-- * Identifier++$(deriveSafeCopy 1 'base ''Identifier)++-- * AuthMap++newtype FacebookId_001 = FacebookId_001 { unFacebookId_001 :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy)++newtype FacebookId = FacebookId { unFacebookId :: Ascii }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 2 'extension ''FacebookId)++instance Migrate FacebookId where+ type MigrateFrom FacebookId = FacebookId_001+ migrate (FacebookId_001 fid) = FacebookId (Text.encodeUtf8 fid)++data AuthMethod_v1+ = AuthIdentifier_v1 { amIdentifier_v1 :: Identifier+ }+ | AuthUserPassId_v1 { amUserPassId_v1 :: UserPassId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 1 'base ''AuthMethod_v1)++data AuthMethod+ = AuthIdentifier { amIdentifier :: Identifier+ }+ | AuthUserPassId { amUserPassId :: UserPassId+ }+ | AuthFacebook { amFacebookId :: FacebookId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 2 'extension ''AuthMethod)++instance Migrate AuthMethod where+ type MigrateFrom AuthMethod = AuthMethod_v1+ migrate (AuthIdentifier_v1 ident) = AuthIdentifier ident+ migrate (AuthUserPassId_v1 up) = AuthUserPassId up+++data AuthMap+ = AuthMap { amMethod :: AuthMethod+ , amAuthId :: AuthId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++$(deriveSafeCopy 1 'base ''AuthMap)++$(inferIxSet "AuthMaps" ''AuthMap 'noCalcs [''AuthId, ''AuthMethod, ''Identifier, ''UserPassId, ''FacebookId])++-- * AuthToken++data AuthToken+ = AuthToken { tokenString :: String+ , tokenExpires :: UTCTime+ , tokenAuthId :: Maybe AuthId+ , tokenAuthMethod :: AuthMethod+ }+ deriving (Eq, Ord, Data, Show, Typeable)+$(deriveSafeCopy 1 'base ''AuthToken)++$(inferIxSet "AuthTokens" ''AuthToken 'noCalcs [''String, ''AuthId])++++-- * AuthState++-- how to we remove expired AuthTokens?+--+-- Since the user might be logged in a several machines they might have several auth tokens. So we can not just expire the old ones everytime they log in.+--+-- Basically we can expired them on: logout and time+--+-- time is tricky because we do not really want to do a db update everytime they access the site+data AuthState+ = AuthState { userPasses :: UserPasses+ , nextUserPassId :: UserPassId+ , authMaps :: AuthMaps+ , nextAuthId :: AuthId+ , authTokens :: AuthTokens+ }+ deriving (Data, Eq, Show, Typeable)+$(deriveSafeCopy 1 'base ''AuthState)++-- | a reasonable initial 'AuthState'+initialAuthState :: AuthState+initialAuthState =+ AuthState { userPasses = IxSet.empty+ , nextUserPassId = UserPassId 1+ , authMaps = IxSet.empty+ , authTokens = IxSet.empty+ , nextAuthId = AuthId 1+ }++-- ** UserPass++modifyUserPass :: UserPassId -> (UserPass -> UserPass) -> Update AuthState (Maybe UserPassError)+modifyUserPass upid fn =+ do as@(AuthState {..}) <- get+ case getOne $ userPasses @= upid of+ Nothing -> return (Just $ InvalidUserPassId upid)+ (Just userPass) ->+ do let userPass' = fn userPass+ put as { userPasses = IxSet.updateIx upid userPass' userPasses }+ return Nothing++-- | errors that can occur when working with 'UserPass'+data UserPassError+ = UsernameInUse UserName+ | InvalidUserPassId UserPassId+ | InvalidUserName UserName+ | InvalidPassword+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''UserPassError)++-- | return a user-friendly error message string for an 'AddAuthError'+userPassErrorString :: UserPassError -> String+userPassErrorString (UsernameInUse (UserName txt)) = "Username already in use: " ++ Text.unpack txt+userPassErrorString (InvalidUserPassId (UserPassId i)) = "Invalid UserPassId " ++ show i+userPassErrorString (InvalidUserName (UserName name)) = "Invalid username " ++ Text.unpack name+userPassErrorString InvalidPassword = "Invalid password"++-- | creates a new 'UserPass'+createUserPass :: UserName -- ^ desired username+ -> HashedPass -- ^ hashed password+ -> Update AuthState (Either UserPassError UserPass)+createUserPass name hashedPass =+ do as@(AuthState{..}) <- get+ if not (IxSet.null $ userPasses @= name)+ then return (Left (UsernameInUse name))+ else do let userPass = UserPass { upName = name+ , upPassword = hashedPass+ , upId = nextUserPassId+ }+ put $ as { userPasses = IxSet.insert userPass userPasses+ , nextUserPassId = succUserPassId nextUserPassId+ }+ return (Right userPass)++-- | change the 'UserName' associated with a 'UserPassId'+-- this will break password salting...+setUserName :: UserPassId -> Text -> Update AuthState (Maybe UserPassError)+setUserName upid name =+ do as <- get+ if nameAvailable (userPasses as)+ then case getOne $ (userPasses as) @= upid of+ (Just userPass) ->+ do put $ as { userPasses = IxSet.updateIx upid (userPass { upName = UserName name }) (userPasses as) }+ return Nothing+ Nothing -> return (Just $ InvalidUserPassId upid)+ else return (Just $ UsernameInUse (UserName name))+ where+ nameAvailable userPasses =+ case IxSet.toList (userPasses @= (UserName name)) of+ [] -> True+ [a] | (upId a == upid) -> True+ _ -> False++-- | hash a password string+mkHashedPass :: Text -- ^ password in plain text+ -> IO HashedPass -- ^ salted and hashed+mkHashedPass pass = HashedPass <$> makePassword (Text.encodeUtf8 pass) 12++-- | verify a password+verifyHashedPass :: Text -- ^ password in plain text+ -> HashedPass -- ^ hashed version of password+ -> Bool+verifyHashedPass passwd (HashedPass hashedPass) =+ verifyPassword (Text.encodeUtf8 passwd) hashedPass++-- | change the password for the give 'UserPassId'+setPassword :: UserPassId -> HashedPass -> Update AuthState (Maybe UserPassError)+setPassword upid hashedPass =+ modifyUserPass upid $ \userPass ->+ userPass { upPassword = hashedPass }++checkUserPass :: Text -> Text -> Query AuthState (Either UserPassError UserPassId)+checkUserPass username password =+ do as@(AuthState{..}) <- ask+ case IxSet.getOne $ userPasses @= (UserName username) of+ Nothing -> return (Left $ InvalidUserName (UserName username))+ (Just userPass)+ | verifyHashedPass password (upPassword userPass) ->+ do return (Right (upId userPass))+ | otherwise -> return (Left InvalidPassword)++askUserPass :: UserPassId -> Query AuthState (Maybe UserPass)+askUserPass uid =+ do as@(AuthState{..}) <-ask+ return $ getOne $ userPasses @= uid++-- ** AuthMap++addAuthMethod :: AuthMethod -> AuthId -> Update AuthState ()+addAuthMethod authMethod authid =+ do as@(AuthState{..}) <- get+ put $ as { authMaps = IxSet.insert (AuthMap authMethod authid) authMaps }++newAuthMethod :: AuthMethod -> Update AuthState AuthId+newAuthMethod authMethod =+ do as@(AuthState{..}) <- get+ put $ as { authMaps = IxSet.insert (AuthMap authMethod nextAuthId) authMaps+ , nextAuthId = succAuthId nextAuthId+ }+ return nextAuthId++removeAuthIdentifier :: Identifier -> AuthId -> Update AuthState ()+removeAuthIdentifier identifier authid =+ do as@(AuthState{..}) <- get+ put $ as { authMaps = IxSet.delete (AuthMap (AuthIdentifier identifier) authid) authMaps }++identifierAuthIds :: Identifier -> Query AuthState (Set AuthId)+identifierAuthIds identifier =+ do as@(AuthState{..}) <- ask+ return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= identifier++facebookAuthIds :: FacebookId -> Query AuthState (Set AuthId)+facebookAuthIds facebookId =+ do as@(AuthState{..}) <- ask+ return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= facebookId+++addAuthUserPassId :: UserPassId -> AuthId -> Update AuthState ()+addAuthUserPassId upid authid =+ do as@(AuthState{..}) <- get+ put $ as { authMaps = IxSet.insert (AuthMap (AuthUserPassId upid) authid) authMaps }++removeAuthUserPassId :: UserPassId -> AuthId -> Update AuthState ()+removeAuthUserPassId upid authid =+ do as@(AuthState{..}) <- get+ put $ as { authMaps = IxSet.delete (AuthMap (AuthUserPassId upid) authid) authMaps }++userPassIdAuthIds :: UserPassId -> Query AuthState (Set AuthId)+userPassIdAuthIds upid =+ do as@(AuthState{..}) <- ask+ return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= upid++-- * AuthToken+++addAuthToken :: AuthToken -> Update AuthState ()+addAuthToken authToken =+ do as@AuthState{..} <- get+ put (as { authTokens = IxSet.insert authToken authTokens })++-- | look up the 'AuthToken' associated with the 'String'+askAuthToken :: String -- ^ token string (used in the cookie)+ -> Query AuthState (Maybe AuthToken)+askAuthToken tokenStr =+ do as@AuthState{..} <- ask+ return $ getOne $ authTokens @= tokenStr++updateAuthToken :: AuthToken -> Update AuthState ()+updateAuthToken authToken =+ do as@AuthState{..} <- get+ put (as { authTokens = IxSet.updateIx (tokenString authToken) authToken authTokens })++deleteAuthToken :: String -> Update AuthState ()+deleteAuthToken tokenStr =+ do as@AuthState{..} <- get+ put (as { authTokens = IxSet.deleteIx tokenStr authTokens })++authTokenAuthId :: String -> Query AuthState (Maybe AuthId)+authTokenAuthId tokenString =+ do as@(AuthState{..}) <- ask+ case getOne $ authTokens @= tokenString of+ Nothing -> return Nothing+ (Just authToken) -> return $ (tokenAuthId authToken)++-- TODO:+-- - expireAuthTokens+-- - tickleAuthToken++-- | generate an new authentication token+genAuthToken :: (MonadIO m) => Maybe AuthId -> AuthMethod -> Int -> m AuthToken+genAuthToken aid authMethod lifetime =+ do random <- liftIO $ B.unpack . exportSalt <$> genSaltIO -- the docs promise that the salt will be base64, so 'B.unpack' should be safe+ now <- liftIO $ getCurrentTime+ let expires = addUTCTime (fromIntegral lifetime) now+ prefix = case aid of+ Nothing -> "0"+ (Just a) -> show (unAuthId a)+ return $ AuthToken { tokenString = prefix ++ random+ , tokenExpires = expires+ , tokenAuthId = aid+ , tokenAuthMethod = authMethod+ }++-- | generate a new, unused 'AuthId'+genAuthId :: Update AuthState AuthId+genAuthId =+ do as@(AuthState {..}) <- get+ put (as { nextAuthId = succAuthId nextAuthId })+ return nextAuthId++askAuthState :: Query AuthState AuthState+askAuthState = ask++$(makeAcidic ''AuthState [ 'askUserPass+ , 'checkUserPass+ , 'createUserPass+ , 'setUserName+ , 'setPassword+ , 'addAuthToken+ , 'askAuthToken+ , 'updateAuthToken+ , 'deleteAuthToken+ , 'authTokenAuthId+ , 'genAuthId+ , 'addAuthMethod+ , 'newAuthMethod+ , 'removeAuthIdentifier+ , 'identifierAuthIds+ , 'facebookAuthIds+ , 'addAuthUserPassId+ , 'removeAuthUserPassId+ , 'userPassIdAuthIds+ , 'askAuthState+ ])++-- * happstack-server level stuff++addAuthCookie :: (Happstack m) => AcidState AuthState -> Maybe AuthId -> AuthMethod -> m ()+addAuthCookie acidH aid authMethod =+ do authToken <- genAuthToken aid authMethod (60*60)+ update' acidH (AddAuthToken authToken)+ addCookie Session (mkCookie "authToken" (tokenString authToken))+ return ()++deleteAuthCookie :: (Happstack m, Alternative m) => AcidState AuthState -> m ()+deleteAuthCookie acidH =+ do mTokenStr <- optional $ lookCookieValue "authToken"+ case mTokenStr of+ Nothing -> return ()+ (Just tokenStr) ->+ do expireCookie "authToken"+ update' acidH (DeleteAuthToken tokenStr)++getAuthToken :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthToken)+getAuthToken acidH =+ do mTokenStr <- optional $ lookCookieValue "authToken"+ case mTokenStr of+ Nothing -> return Nothing+ (Just tokenStr) ->+ query' acidH (AskAuthToken tokenStr)++getAuthId :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthId)+getAuthId acidH =+ do mTokenStr <- optional $ lookCookieValue "authToken"+ case mTokenStr of+ Nothing -> return Nothing+ (Just tokenStr) -> query' acidH (AuthTokenAuthId tokenStr)
+ Happstack/Auth/Core/AuthParts.hs view
@@ -0,0 +1,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, authenticate, 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'+ (identifier, _) <- liftIO $ withManager $ authenticate pairs+ return identifier++-- 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 ())+
+ Happstack/Auth/Core/AuthProfileURL.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module Happstack.Auth.Core.AuthProfileURL where++import Control.Applicative ((<$>))+import Control.Monad (msum)+import Data.Data (Data, Typeable)+import Happstack.Auth.Core.AuthURL (AuthURL(..))+import Happstack.Auth.Core.ProfileURL (ProfileURL(..))+import Web.Routes (PathInfo(..), segment)+import Test.QuickCheck (Arbitrary(..), oneof)++data AuthProfileURL + = AuthURL AuthURL+ | ProfileURL ProfileURL+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance PathInfo AuthProfileURL where+ toPathSegments (AuthURL authURL) = "auth" : toPathSegments authURL+ toPathSegments (ProfileURL profileURL) = "profile" : toPathSegments profileURL+ fromPathSegments = + msum [ do segment "auth"+ AuthURL <$> fromPathSegments+ , do segment "profile"+ ProfileURL <$> fromPathSegments+ ]++instance Arbitrary AuthProfileURL where+ arbitrary = oneof [ AuthURL <$> arbitrary + , ProfileURL <$> arbitrary+ ]
+ Happstack/Auth/Core/AuthURL.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings #-}+module Happstack.Auth.Core.AuthURL where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (msum)+import Data.Data (Data, Typeable)+import Data.Text (unpack)+import Test.QuickCheck (Arbitrary(..), Property, property, oneof)+import Web.Routes (PathInfo(..), pathInfoInverse_prop, segment)++data OpenIdProvider+ = Google+ | Yahoo+ | Myspace+ | LiveJournal+ | Generic+ deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded)++instance PathInfo OpenIdProvider where+ toPathSegments Google = ["google"]+ toPathSegments Yahoo = ["yahoo"]+ toPathSegments Myspace = ["myspace"]+ toPathSegments LiveJournal = ["livejournal"]+ toPathSegments Generic = ["generic"]+ fromPathSegments =+ msum [ do segment "google"+ return Google+ , do segment "yahoo"+ return Yahoo+ , do segment "myspace"+ return Myspace+ , do segment "livejournal"+ return LiveJournal+ , do segment "generic"+ return Generic+ ]++instance Arbitrary OpenIdProvider where+ arbitrary = oneof $ map return [ minBound .. maxBound ]++data AuthMode + = LoginMode+ | AddIdentifierMode+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance PathInfo AuthMode where+ toPathSegments LoginMode = ["login"]+ toPathSegments AddIdentifierMode = ["add_identifier"]+ fromPathSegments =+ msum [ do segment "login"+ return LoginMode+ , do segment "add_identifier"+ return AddIdentifierMode+ ]+ + +instance Arbitrary AuthMode where+ arbitrary = oneof [ return LoginMode+ , return AddIdentifierMode+ ]++data AuthURL+ = A_Login+ | A_AddAuth+ | A_Logout+ | A_Local+ | A_CreateAccount+ | A_ChangePassword+ | A_OpenId OpenIdURL+ | A_OpenIdProvider AuthMode OpenIdProvider+ | A_Facebook AuthMode+ | A_FacebookRedirect AuthMode+ deriving (Eq, Ord, Read, Show, Data, Typeable)++data OpenIdURL+ = O_OpenId AuthMode+ | O_Connect AuthMode+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance Arbitrary OpenIdURL where+ arbitrary = oneof [ O_OpenId <$> arbitrary+ , O_Connect <$> arbitrary+ ]++instance Arbitrary AuthURL where+ arbitrary = oneof [ return A_Login+ , return A_Logout+ , return A_Local+ , return A_AddAuth+ , return A_CreateAccount+ , return A_ChangePassword+ , A_OpenId <$> arbitrary+ , A_OpenIdProvider <$> arbitrary <*> arbitrary+ , A_Facebook <$> arbitrary+ , A_FacebookRedirect <$> arbitrary+ ]++instance PathInfo OpenIdURL where+ toPathSegments (O_OpenId authMode) = "openid_return" : toPathSegments authMode+ toPathSegments (O_Connect authMode) = "connect" : toPathSegments authMode++ fromPathSegments =+ msum [ do segment "openid_return"+ mode <- fromPathSegments+ return (O_OpenId mode)+ , do segment "connect"+ authMode <- fromPathSegments+ return (O_Connect authMode)+ ]++instance PathInfo AuthURL where+ toPathSegments A_Login = ["login"]+ toPathSegments A_Logout = ["logout"]+ toPathSegments A_Local = ["local"]+ toPathSegments A_CreateAccount = ["create"]+ toPathSegments A_ChangePassword = ["change_password"]+ toPathSegments A_AddAuth = ["add_auth"]+ toPathSegments (A_OpenId o) = "openid" : toPathSegments o+ toPathSegments (A_OpenIdProvider authMode provider) = "provider" : toPathSegments authMode ++ toPathSegments provider + toPathSegments (A_Facebook authMode) = "facebook" : toPathSegments authMode+ toPathSegments (A_FacebookRedirect authMode) = "facebook-redirect" : toPathSegments authMode++ fromPathSegments =+ msum [ do segment "login"+ return A_Login+ , do segment "logout"+ return A_Logout+ , do segment "local"+ return A_Local+ , do segment "create"+ return A_CreateAccount+ , do segment "change_password"+ return A_ChangePassword+ , do segment "openid"+ A_OpenId <$> fromPathSegments+ , do segment "add_auth"+ return A_AddAuth+ , do segment "provider"+ authMode <- fromPathSegments+ provider <- fromPathSegments+ return (A_OpenIdProvider authMode provider)+ , do segment "facebook"+ authMode <- fromPathSegments+ return (A_Facebook authMode)+ , do segment "facebook-redirect"+ authMode <- fromPathSegments+ return (A_FacebookRedirect authMode)+ ]++authUrlInverse :: Property+authUrlInverse =+ property (pathInfoInverse_prop :: AuthURL -> Bool)
+ Happstack/Auth/Core/Profile.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable,+ FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances, TypeOperators, RecordWildCards+ #-}++module Happstack.Auth.Core.Profile where++import Control.Applicative +import Control.Monad.Reader+import Control.Monad.State+import Data.Acid (AcidState, Update, Query, makeAcidic)+import Data.Acid.Advanced (query', update')+import Data.Data+import Data.IxSet (IxSet, (@=), inferIxSet, noCalcs)+import qualified Data.IxSet as IxSet+import Data.Map (Map)+import qualified Data.Map as Map+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Happstack.Auth.Core.Auth+import Happstack.Server+import Web.Routes++newtype UserId = UserId { unUserId :: Integer }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''UserId)++instance PathInfo UserId where+ toPathSegments (UserId i) = toPathSegments i+ fromPathSegments = UserId <$> fromPathSegments++succUserId :: UserId -> UserId+succUserId (UserId i) = UserId (succ i)+++data Profile + = Profile+ { userId :: UserId+ , auths :: Set AuthId+ , nickName :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''Profile)++$(inferIxSet "Profiles" ''Profile 'noCalcs [''UserId, ''AuthId])++data ProfileState + = ProfileState { profiles :: Profiles+ , authUserMap :: Map AuthId UserId -- ^ map of what 'UserId' an 'AuthId' is currently defaulting to+ , nextUserId :: UserId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'base ''ProfileState)++-- | a reasonable initial 'ProfileState'+initialProfileState :: ProfileState+initialProfileState =+ ProfileState { profiles = IxSet.empty+ , authUserMap = Map.empty+ , nextUserId = UserId 1+ }++-- | Retrieve the entire ProfileState+-- Warning, this is an admin level function?+getProfileState :: Query ProfileState ProfileState+getProfileState =+ do ps <- ask+ return ps++genUserId :: Update ProfileState UserId+genUserId =+ do as@(ProfileState {..}) <- get+ put (as { nextUserId = succUserId nextUserId })+ return nextUserId++-- return the UserId currently prefered by this AuthId+--+-- can be Nothing if no preference is set, even if there are possible UserIds+authIdUserId :: AuthId -> Query ProfileState (Maybe UserId)+authIdUserId aid =+ do ps@(ProfileState {..}) <- ask+ return $ Map.lookup aid authUserMap ++-- return all the Profiles associated with this AuthId+authIdProfiles :: AuthId -> Query ProfileState (Set Profile)+authIdProfiles aid =+ do ps@(ProfileState {..}) <- ask+ return $ IxSet.toSet (profiles @= aid)++setAuthIdUserId :: AuthId -> UserId -> Update ProfileState ()+setAuthIdUserId authId userId =+ do ps@(ProfileState{..}) <- get+ put $ ps { authUserMap = Map.insert authId userId authUserMap }++createNewProfile :: Set AuthId -> Update ProfileState UserId+createNewProfile authIds =+ do ps@(ProfileState{..}) <- get+ let profile = Profile { userId = nextUserId+ , auths = authIds+ , nickName = Text.pack "Anonymous"+ }+ put $ (ps { profiles = IxSet.insert profile profiles + , nextUserId = succUserId nextUserId+ })+ return nextUserId++$(makeAcidic ''ProfileState + [ 'authIdUserId+ , 'authIdProfiles+ , 'setAuthIdUserId+ , 'createNewProfile+ , 'genUserId+ , 'getProfileState+ ])++getUserId :: (Alternative m, Happstack m) => AcidState AuthState -> AcidState ProfileState -> m (Maybe UserId)+getUserId authStateH profileStateH =+ do mAuthToken <- getAuthToken authStateH+ case mAuthToken of+ Nothing -> return Nothing+ (Just authToken) ->+ case tokenAuthId authToken of+ Nothing -> return Nothing+ (Just authId) -> query' profileStateH (AuthIdUserId authId)+++
+ Happstack/Auth/Core/ProfileParts.hs view
@@ -0,0 +1,76 @@+module Happstack.Auth.Core.ProfileParts where++import Control.Applicative (Alternative(..))+import Data.Acid (AcidState)+import Data.Acid.Advanced (update', query')+import Data.Set (Set)+import qualified Data.Set as Set+import Happstack.Server+import Happstack.Auth.Core.Auth+import Happstack.Auth.Core.ProfileURL+import Happstack.Auth.Core.Profile+import Web.Routes+import Web.Routes.Happstack++-- * ProfileURL stuff++-- can we pick an AuthId with only the information in the Auth stuff? Or should that be a profile action ?++pickAuthId :: (Happstack m, Alternative m) => AcidState AuthState -> m (Either (Set AuthId) AuthId)+pickAuthId authStateH =+ do (Just authToken) <- getAuthToken authStateH -- FIXME: Just + case tokenAuthId authToken of+ (Just authId) -> return (Right authId)+ Nothing ->+ do authIds <- case tokenAuthMethod authToken of+ (AuthIdentifier identifier) -> query' authStateH (IdentifierAuthIds identifier)+ (AuthFacebook facebookId) -> query' authStateH (FacebookAuthIds facebookId)+ case Set.size authIds of+ 0 -> do authId <- update' authStateH (NewAuthMethod (tokenAuthMethod authToken))+ update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just authId }))+ return (Right authId)+ 1 -> do let aid = head $ Set.toList authIds+ update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just aid }))+ return (Right aid)+ n -> return (Left authIds)++setAuthIdPage :: (Alternative m, Happstack m) => AcidState AuthState -> AuthId -> m Bool+setAuthIdPage authStateH authId =+ do mAuthToken <- getAuthToken authStateH+ case mAuthToken of+ Nothing -> undefined -- FIXME+ (Just authToken) ->+ do authIds <- case tokenAuthMethod authToken of+ (AuthIdentifier identifier) -> query' authStateH (IdentifierAuthIds identifier)+ (AuthFacebook facebookId) -> query' authStateH (FacebookAuthIds facebookId)+ if Set.member authId authIds+ then do update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just authId }))+ return True+ else return False++data PickProfile + = Picked UserId+ | PickPersonality (Set Profile)+ | PickAuthId (Set AuthId)++pickProfile :: (Happstack m, Alternative m) => AcidState AuthState -> AcidState ProfileState -> m PickProfile+pickProfile authStateH profileStateH =+ do eAid <- pickAuthId authStateH+ case eAid of+ (Right aid) ->+ do mUid <- query' profileStateH (AuthIdUserId aid)+ case mUid of+ Nothing ->+ do profiles <- query' profileStateH (AuthIdProfiles aid)+ case Set.size profiles of+ 0 -> do uid <- update' profileStateH (CreateNewProfile (Set.singleton aid))+ update' profileStateH (SetAuthIdUserId aid uid)+ return (Picked uid)+-- seeOther onLoginURL (toResponse onLoginURL)+ 1 -> do let profile = head $ Set.toList profiles+ update' profileStateH (SetAuthIdUserId aid (userId profile))+ return (Picked (userId profile))+ n -> do return (PickPersonality profiles)+ (Just uid) ->+ return (Picked uid)+ (Left aids) -> return (PickAuthId aids)
+ Happstack/Auth/Core/ProfileURL.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings #-}+module Happstack.Auth.Core.ProfileURL where++import Control.Applicative ((<$>))+import Control.Monad (msum)+import Data.Data (Data, Typeable)+import Happstack.Auth.Core.Auth (AuthId(..))+import Happstack.Auth.Core.Profile (UserId(..))+import Test.QuickCheck (Arbitrary(..), Property, arbitrary, property, oneof)++import Web.Routes+data ProfileURL+ = P_SetPersonality UserId+ | P_SetAuthId AuthId+ | P_PickProfile+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance Arbitrary ProfileURL where+ arbitrary = oneof $ [ P_SetPersonality . UserId <$> arbitrary+ , P_SetAuthId . AuthId <$> arbitrary+ , return P_PickProfile+ ]+++instance PathInfo ProfileURL where+ toPathSegments (P_SetPersonality userId) = "set_personality" : toPathSegments userId+ toPathSegments (P_SetAuthId authId) = "set_authid" : toPathSegments authId+ toPathSegments P_PickProfile = ["pick_profile"]++ fromPathSegments =+ msum [ do segment "set_personality"+ userId <- fromPathSegments+ return (P_SetPersonality userId)+ , do segment "set_authid"+ authId <- fromPathSegments+ return (P_SetAuthId authId)+ , do segment "pick_profile"+ return P_PickProfile+ ]++authUrlInverse :: Property+authUrlInverse =+ property (pathInfoInverse_prop :: ProfileURL -> Bool)++{-+instance EmbedAsAttr (RouteT ProfileURL (ServerPartT IO)) (Attr String ProfileURL) where+ asAttr (n := u) = + do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal url)+-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, SeeReason Partners LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of SeeReason Partners LLC nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-authenticate.cabal view
@@ -0,0 +1,50 @@+Name: happstack-authenticate+Version: 0.9.2+Synopsis: Happstack Authentication Library+Description: A themeable authentication library with support for username+password and OpenId.+Homepage: http://src.seereason.com/happstack-authenticate+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw.+Maintainer: jeremy@seereason.com+Copyright: 2011 SeeReason Partners, LLC+Category: Web+Build-type: Simple+Cabal-version: >=1.6++Library++ Exposed-modules: Happstack.Auth+ Happstack.Auth.Blaze.Templates+ Happstack.Auth.Core.Profile,+ Happstack.Auth.Core.Auth,+ Happstack.Auth.Core.ProfileURL,+ Happstack.Auth.Core.AuthParts,+ Happstack.Auth.Core.ProfileParts,+ Happstack.Auth.Core.AuthURL,+ Happstack.Auth.Core.AuthProfileURL++ Build-depends: base > 4 && < 5,+ acid-state == 0.6.*,+ aeson >= 0.4 && < 0.7,+ authenticate == 1.2.*,+ blaze-html == 0.5.*,+ bytestring == 0.9.*,+ containers == 0.4.*,+ ixset >= 1.0 && < 1.1,+ happstack-server >= 6.0 && < 7.1,+ http-conduit == 1.4.*,+ http-types == 0.6.*,+ fb == 0.9.*,+ safecopy == 0.6.*,+ mtl >= 2.0,+ pwstore-purehaskell == 2.1.*,+ QuickCheck >= 2,+ text == 0.11.*,+ time >= 1.2 && < 1.5,+ reform == 0.1.*,+ reform-blaze == 0.1.*,+ reform-happstack == 0.1.*,+ unordered-containers == 0.2.*,+ web-routes >= 0.26 && < 0.28,+ web-routes-happstack == 0.23.*