happstack-authenticate 0.10.15 → 2.6.1
raw patch · 30 files changed
Files
- Happstack/Auth.hs +0/−22
- Happstack/Auth/Blaze/Templates.hs +0/−659
- Happstack/Auth/Core/Auth.hs +0/−592
- Happstack/Auth/Core/AuthParts.hs +0/−137
- Happstack/Auth/Core/AuthProfileURL.hs +0/−30
- Happstack/Auth/Core/AuthURL.hs +0/−157
- Happstack/Auth/Core/Profile.hs +0/−130
- Happstack/Auth/Core/ProfileParts.hs +0/−76
- Happstack/Auth/Core/ProfileURL.hs +0/−50
- Happstack/Authenticate/Controller.hs +145/−0
- Happstack/Authenticate/Core.hs +910/−0
- Happstack/Authenticate/OpenId/Controllers.hs +88/−0
- Happstack/Authenticate/OpenId/Core.hs +245/−0
- Happstack/Authenticate/OpenId/Partials.hs +93/−0
- Happstack/Authenticate/OpenId/PartialsURL.hs +27/−0
- Happstack/Authenticate/OpenId/Route.hs +79/−0
- Happstack/Authenticate/OpenId/URL.hs +53/−0
- Happstack/Authenticate/Password/Controllers.hs +316/−0
- Happstack/Authenticate/Password/Core.hs +535/−0
- Happstack/Authenticate/Password/Partials.hs +208/−0
- Happstack/Authenticate/Password/PartialsURL.hs +38/−0
- Happstack/Authenticate/Password/Route.hs +82/−0
- Happstack/Authenticate/Password/URL.hs +77/−0
- Happstack/Authenticate/Route.hs +66/−0
- happstack-authenticate.cabal +64/−37
- messages/core/en.msg +12/−0
- messages/openid/error/en.msg +3/−0
- messages/openid/partials/en.msg +4/−0
- messages/password/error/en.msg +11/−0
- messages/password/partials/en.msg +12/−0
− Happstack/Auth.hs
@@ -1,22 +0,0 @@-module Happstack.Auth- ( UserId(..)- , AuthState(..)- , ProfileState(..)- , AuthProfileURL(..)- , AuthURL(..)- , ProfileURL(..)- , getUserId- , authProfileHandler- , handleAuth- , handleProfile- , handleAuthProfile- , handleAuthProfileRouteT- ) 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, handleAuthProfileRouteT)
− Happstack/Auth/Blaze/Templates.hs
@@ -1,659 +0,0 @@-{-# 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- , handleAuthProfileRouteT- , 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)- signupURL <- H.toValue <$> showURL A_Signup- return $ H.div ! A.id "happstack-authenticate" $ do- 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 ()- H.p $ (a ! href signupURL $ "Create a New Account.")--signupPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html-signupPage 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_CreateAccount- facebookURL <- H.toValue <$> showURL (A_Facebook LoginMode)- return $ H.div ! A.id "happstack-authenticate" $- H.ol $ do- H.li $ (a ! href googleURL $ "Signup") >> " with your Google account"- H.li $ (a ! href yahooURL $ "Signup") >> " with your Yahoo account"- H.li $ (a ! href liveJournalURL $ "Signup") >> " with your Live Journal account"- H.li $ (a ! href myspaceURL $ "Signup") >> " with your Myspace account"- H.li $ (a ! href genericURL $ "Signup") >> " with your OpenId account"- H.li $ (a ! href localURL $ "Signup") >> " with a username and password"- case mFacebook of- (Just _) -> H.li $ (a ! href facebookURL $ "Signup") >> " 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, MonadIO m) => AuthForm m Text- usernameForm =- divInline (label' "http://www.myspace.com/" ++> inputText mempty)- <* (divFormActions $ 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, MonadIO m) => AuthForm m Text-liveJournalForm =- divInline (label' "http://" ++> inputText mempty <++ label' ".livejournal.com/")- <* divFormActions (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, MonadIO m) => AuthForm m Text- openIdURLForm =- divInline (label' ("Your OpenId url: " :: String) ++> inputText mempty) <*- divFormActions (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_Signup -> appTemplate "Signup" mempty =<< signupPage mFacebook- 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- }---- | this is a simple entry point into @happstack-authenticate@ that--- provides reasonable default behavior. A majority of the time you--- will just call this function.-authProfileHandler :: (Happstack m) =>- Text -- ^ baseURI for this server part- -> Text -- ^ unique path prefix- -> AcidState AuthState -- ^ handle for 'AcidState AuthState'- -> AcidState ProfileState -- ^ handle for 'AcidState ProfileState'- -> (String -> Html -> Html -> m Response) -- ^ template function used to render pages- -> Maybe Credentials -- ^ optional Facebook 'Credentials'- -> Maybe Text -- ^ optional realm to use for @OpenId@ authentication- -> Text -- ^ url to redirect to if authentication and profile selection is successful- -> 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 =- divHorizontal $- fieldset $- (errorList ++>- (((,) <$> (divControlGroup $ errorList ++> label' "username: " ++> divControls (inputText mempty))- <*> (divControlGroup $ errorList ++> label' "password: " ++> divControls (inputPassword))- <* divFormActions (inputSubmit' "Login")) `transformEitherM` checkAuth)- <* (create createURL))-- create createURL = view $ p $ do "or "- H.a ! href (toValue createURL) $ "create a new account"-- 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 =- divHorizontal $- (R.fieldset- (errorList ++>- (((,) <$> username <*> password <* submitButton)))- `transformEitherM`- createAccount)- where- submitButton = divFormActions $ inputSubmit' "Create Account"- username = divControlGroup $ errorList ++> ((label' "username: " ++> divControls (inputText mempty)) `transformEither` (minLength 1))- password1 = divControlGroup $ label' "password: " ++> divControls inputPassword- password2 = divControlGroup $ label' "confirm password: " ++> divControls 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 =- divHorizontal $- fieldset $- oldPassword *> newPassword <* changeBtn- where- -- form elements- oldPassword =- errorList ++>- (divControlGroup $ label' "old password: " ++> divControls 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, MonadIO v) => AuthForm v Text- password1 = divControlGroup $ label' "new password: " ++> divControls inputPassword- password2 = divControlGroup $ label' "new confirm password: " ++> divControls inputPassword-- newPassword :: (Functor v, MonadIO 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, MonadIO v) => AuthForm v (Maybe Text)- changeBtn = divFormActions $ inputSubmit' "change" -- 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)---divControlGroup :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a-divControlGroup = mapView (\html -> H.div ! class_ "control-group" $ html)--divControls :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a-divControls = mapView (\html -> H.div ! class_ "controls" $ html)--label' :: (Functor m, MonadIO m) => String -> AuthForm m ()-label' str = mapView (\html -> html ! class_"control-label") (R.label str)--divHorizontal :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a-divHorizontal = mapView (\html -> H.div ! class_ "form-horizontal" $ html)--divInline :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a-divInline = mapView (\html -> H.div ! class_ "form-inline" $ html)--divFormActions :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a-divFormActions = mapView (\html -> H.div ! class_ "form-actions" $ html)--inputSubmit' :: (Functor m, MonadIO m) => Text -> AuthForm m (Maybe Text)-inputSubmit' str = mapView (\html -> html ! class_ "btn") (R.inputSubmit str)--{--inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]-inputCheckboxLabel lbl b =- mapView (\xml -> [<label class="checkbox"><% xml %><% lbl %></label>])- (inputCheckbox b)--label' str = (label str `setAttrs` [("class":="control-label")])--labelCB str = label str `setAttrs` [("class":="checkbox")]--- divInline = mapView (\xml -> [<div class="checkbox inline"><% xml %></div>])-divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])-divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])-divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])-divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])--}
− Happstack/Auth/Core/Auth.hs
@@ -1,592 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable,- FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts,- UndecidableInstances, TypeOperators, RecordWildCards, StandaloneDeriving- #-}-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(..)- , GenAuthId(..)- , AddAuthMethod(..)- , NewAuthMethod(..)- , RemoveAuthIdentifier(..)- , IdentifierAuthIds(..)- , FacebookAuthIds(..)- , AddAuthUserPassId(..)- , RemoveAuthUserPassId(..)- , UserPassIdAuthIds(..)- , AskAuthState(..)- , SetDefaultSessionTimeout(..)- , GetDefaultSessionTimeout(..)- , 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, modify)-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 (Indexable(..), IxSet, (@=), inferIxSet, noCalcs, inferIxSet, ixFun, ixSet, 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, diffUTCTime, getCurrentTime)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import Data.Text (Text)-import Facebook (UserId, Id(..))-import Web.Authenticate.OpenId (Identifier)-import Web.Routes (PathInfo(..))-import Happstack.Server (Cookie(..), CookieLife(..), Happstack, Request(rqSecure), addCookie, askRq, 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)---- | NOTE: The Eq and Ord instances are 'case-insensitive'. They apply 'toCaseFold' before comparing.-newtype UserName = UserName { unUserName :: Text }- deriving (Read, Show, Data, Typeable)-$(deriveSafeCopy 1 'base ''UserName)--instance Eq UserName where- (UserName x) == (UserName y) = (Text.toCaseFold x) == (Text.toCaseFold y)- (UserName x) /= (UserName y) = (Text.toCaseFold x) /= (Text.toCaseFold y)--instance Ord UserName where- compare (UserName x) (UserName y) = compare (Text.toCaseFold x) (Text.toCaseFold y)- (UserName x) < (UserName y) = (Text.toCaseFold x) < (Text.toCaseFold y)- (UserName x) >= (UserName y) = (Text.toCaseFold x) >= (Text.toCaseFold y)- (UserName x) > (UserName y) = (Text.toCaseFold x) > (Text.toCaseFold y)- (UserName x) <= (UserName y) = (Text.toCaseFold x) <= (Text.toCaseFold y)- max (UserName x) (UserName y) = UserName $ max (Text.toCaseFold x) (Text.toCaseFold y)- min (UserName x) (UserName y) = UserName $ min (Text.toCaseFold x) (Text.toCaseFold y)--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)--instance SafeCopy FacebookId_001 where- kind = base- getCopy = contain $ (FacebookId_001 . Text.decodeUtf8) <$> safeGet- putCopy = contain . safePut . Text.encodeUtf8 . unFacebookId_001- errorTypeName _ = "FacebookId_001"--newtype FacebookId_002 = FacebookId_002 { unFacebookId_002 :: B.ByteString }- deriving (Eq, Ord, Read, Show, Data, Typeable)-$(deriveSafeCopy 2 'extension ''FacebookId_002)--instance Migrate FacebookId_002 where- type MigrateFrom FacebookId_002 = FacebookId_001- migrate (FacebookId_001 fid) = FacebookId_002 (Text.encodeUtf8 fid)--deriving instance Data Id-$(deriveSafeCopy 0 'base ''Id)--newtype FacebookId = FacebookId { unFacebookId :: UserId }- deriving (Eq, Ord, Read, Show, Data, Typeable)-$(deriveSafeCopy 3 'extension ''FacebookId)--instance Migrate FacebookId where- type MigrateFrom FacebookId = FacebookId_002- migrate (FacebookId_002 fid) = FacebookId (Id $ Text.decodeUtf8 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----- | This links an authentication method (such as on OpenId 'Identifier', a 'FacebookId', or 'UserPassId') to an 'AuthId'.-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_001- = AuthToken_001 { tokenString_001 :: String- , tokenExpires_001 :: UTCTime- , tokenAuthId_001 :: Maybe AuthId- , tokenAuthMethod_001 :: AuthMethod- }- deriving (Eq, Ord, Data, Show, Typeable)-$(deriveSafeCopy 1 'base ''AuthToken_001)---data AuthToken- = AuthToken { tokenString :: String- , tokenExpires :: UTCTime- , tokenLifetime :: Int- , tokenAuthId :: Maybe AuthId- , tokenAuthMethod :: AuthMethod- }- deriving (Eq, Ord, Data, Show, Typeable)-$(deriveSafeCopy 2 'extension ''AuthToken)--instance Migrate AuthToken where- type MigrateFrom AuthToken = AuthToken_001- migrate (AuthToken_001 ts te tid tam) =- (AuthToken ts te 3600 tid tam)--instance Indexable AuthToken where- empty = ixSet [ ixFun $ (:[]) . tokenString- , ixFun $ (:[]) . tokenAuthId- ]--type AuthTokens = IxSet AuthToken---- * 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_1- = AuthState_1 { userPasses_1 :: UserPasses- , nextUserPassId_1 :: UserPassId- , authMaps_1 :: AuthMaps- , nextAuthId_1 :: AuthId- , authTokens_1 :: AuthTokens- }- deriving (Data, Eq, Show, Typeable)-$(deriveSafeCopy 1 'base ''AuthState_1)--data AuthState- = AuthState { userPasses :: UserPasses- , nextUserPassId :: UserPassId- , authMaps :: AuthMaps- , nextAuthId :: AuthId- , authTokens :: AuthTokens- , defaultSessionTimeout :: Int- }- deriving (Data, Eq, Show, Typeable)-$(deriveSafeCopy 2 'extension ''AuthState)--instance Migrate AuthState where- type MigrateFrom AuthState = AuthState_1- migrate (AuthState_1 up nup am nai at) =- (AuthState up nup am nai at (60*60))---- | a reasonable initial 'AuthState'-initialAuthState :: AuthState-initialAuthState =- AuthState { userPasses = IxSet.empty- , nextUserPassId = UserPassId 1- , authMaps = IxSet.empty- , authTokens = IxSet.empty- , nextAuthId = AuthId 1- , defaultSessionTimeout = 60*60- }---- ** 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---- * Default timeout--setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180)- -> Update AuthState ()-setDefaultSessionTimeout newTimeout =- modify $ \as@AuthState{..} -> as { defaultSessionTimeout = newTimeout }--getDefaultSessionTimeout :: Query AuthState Int-getDefaultSessionTimeout =- defaultSessionTimeout <$> ask---- * 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 })--purgeExpiredTokens :: UTCTime- -> Update AuthState ()-purgeExpiredTokens now =- do as@AuthState{..} <- get- let authTokens' = IxSet.fromList $ filter (\at -> (tokenExpires at) > now) (IxSet.toList authTokens)- put as { authTokens = authTokens'}---- | deprecated------ this function is deprecated because it is not possible to check if the session has expired-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)---- | 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- , 'purgeExpiredTokens- , 'authTokenAuthId- , 'genAuthId- , 'addAuthMethod- , 'newAuthMethod- , 'removeAuthIdentifier- , 'identifierAuthIds- , 'facebookAuthIds- , 'addAuthUserPassId- , 'removeAuthUserPassId- , 'userPassIdAuthIds- , 'askAuthState- , 'setDefaultSessionTimeout- , 'getDefaultSessionTimeout- ])---- * happstack-server level stuff---- 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- , tokenLifetime = lifetime- , tokenAuthId = aid- , tokenAuthMethod = authMethod- }---- Also calls 'PurgeExpiredTokens'-addAuthCookie :: (Happstack m) =>- AcidState AuthState- -> Maybe AuthId- -> AuthMethod- -> m ()-addAuthCookie acidH aid authMethod =- do lifetime <- query' acidH GetDefaultSessionTimeout- authToken <- genAuthToken aid authMethod lifetime- now <- liftIO $ getCurrentTime- update' acidH (PurgeExpiredTokens now)- update' acidH (AddAuthToken authToken)- s <- rqSecure <$> askRq- addCookie (MaxAge $ 3600*24*7*52) ((mkCookie "authToken" (tokenString authToken)) { secure = s })- 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)-{--getAuthCookie :: (Alternative m, Happstack m) =>- AcidState AuthState- -> m (Maybe AuthToken)-getAuthCookie acidH =- do mTokenStr <- optional $ lookCookieValue "authToken"--}-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) ->- do mAuthToken <- query' acidH (AskAuthToken tokenStr)- case mAuthToken of- Nothing -> return Nothing- (Just authToken) ->- do now <- liftIO $ getCurrentTime- if now > (tokenExpires authToken)- then do expireCookie "authToken"- update' acidH (DeleteAuthToken tokenStr)- return Nothing- else if (diffUTCTime (addUTCTime (fromIntegral $ tokenLifetime authToken) now) (tokenExpires authToken)) > 60- then do let newAuthToken = authToken { tokenExpires = addUTCTime (fromIntegral $ tokenLifetime authToken) now }- update' acidH (UpdateAuthToken newAuthToken)- return (Just newAuthToken)- else return (Just authToken)---getAuthId :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthId)-getAuthId acidH =- do mAuthToken <- getAuthToken acidH- case mAuthToken of- Nothing -> return Nothing- (Just authToken) ->- return $ (tokenAuthId authToken)
− Happstack/Auth/Core/AuthParts.hs
@@ -1,137 +0,0 @@-{-# 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 ())-
− Happstack/Auth/Core/AuthProfileURL.hs
@@ -1,30 +0,0 @@-{-# 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
@@ -1,157 +0,0 @@-{-# 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_Signup- | 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_AddAuth- , return A_Logout- , return A_Signup- , return A_Local- , 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_Signup = ["signup"]- 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 "signup"- return A_Signup- , 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
@@ -1,130 +0,0 @@-{-# 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
@@ -1,76 +0,0 @@-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
@@ -1,50 +0,0 @@-{-# 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)--}
+ Happstack/Authenticate/Controller.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE QuasiQuotes #-}+module Happstack.Authenticate.Controller where++import Data.Text (Text)+import qualified Data.Text as T+import Happstack.Authenticate.Core (AuthenticateURL)+import Language.Javascript.JMacro+import Web.Routes (RouteT, askRouteFn)++authenticateCtrl :: (Monad m) => RouteT AuthenticateURL m JStat+authenticateCtrl =+ do fn <- askRouteFn+ return $ authenticateCtrlJs fn++authenticateCtrlJs :: (AuthenticateURL -> [(Text, Maybe Text)] -> Text) -> JStat+authenticateCtrlJs showURL = [jmacro|+ {+ //this is used to parse the profile+ function url_base64_decode(str) {+ var output = str.replace('-', '+').replace('_', '/');+ switch (output.length % 4) {+ case 0:+ break;+ case 2:+ output += '==';+ break;+ case 3:+ output += '=';+ break;+ default:+ throw 'Illegal base64url string!';+ }+ return window.atob(output); //polifyll https://github.com/davidchambers/Base64.js+ }++ // declare happstackAuthentication module+ var happstackAuthentication = angular.module('happstackAuthentication', []);++ // add controller+ happstackAuthentication.controller('AuthenticationCtrl', ['$scope', 'userService', function ($scope, userService) {+ $scope.isAuthenticated = userService.getUser().isAuthenticated;+ $scope.$watch(function () { return userService.getUser().isAuthenticated; }, function(newVal, oldVal) { $scope.isAuthenticated = newVal; });+ $scope.claims = userService.getUser().claims;+ $scope.$watch(function () { return userService.getUser().claims; },+ function(newVal, oldVal) { $scope.claims = newVal; }+ );++ $scope.logout = function () {+ userService.clearUser();+ document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;';+ };++ }]);++ happstackAuthentication.factory('authInterceptor', ['$rootScope', '$q', '$window', 'userService', function ($rootScope, $q, $window, userService) {+ return {+ 'request': function (config) {+ config.headers = config.headers || {};+ u = userService.getUser();+ if (u && u.token) {+ config.headers.Authorization = 'Bearer ' + u.token;+ }+ return config;+ },+ 'responseError': function (rejection) {+ if (rejection.status === 401) {+ // handle the case where the user is not authenticated+ userService.clearUser();+ document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;';+ }+ return $q.reject(rejection);+ }+ };+ }]);++ happstackAuthentication.config(['$httpProvider', function ($httpProvider) {+ $httpProvider.interceptors.push('authInterceptor');+ }]);++ // add userService+ happstackAuthentication.factory('userService', ['$rootScope', function ($rootScope) {++ var service = {+ userCache: null,+ userCacheInit: function () {+ var item = localStorage.getItem('user');+ if (item) {+// alert('getUser: ' + item);+ this.setUser(JSON.parse(item));+ } else {+// alert('no user saved.');+ service.clearUser();+ }+ },+ updateFromToken: function (token) {+ var encodedClaims = token.split('.')[1];+ var claims = JSON.parse(url_base64_decode(encodedClaims));+ u = this.getUser();++ u.isAuthenticated = true;+ u.token = token;+ u.claims = claims;+// alert(JSON.stringify(u));+ this.setUser(u);+ return(u);+ },++ setUser: function(u) {+// alert('setUser:' + JSON.stringify(u));+ this.userCache = u;+ localStorage.setItem('user', JSON.stringify(u));+ },++ getUser: function() {+ function getCookie(cname) {+ var name = cname + "=";+ var ca = document.cookie.split(';');+ for(var i=0; i<ca.length; i++) {+ var c = ca[i];+ while (c.charAt(0)==' ') c = c.substring(1);+ if (c.indexOf(name) == 0) return c.substring(name.length,c.length);+ }+ return "";+ };+ if (getCookie('atc').length == 0 && this.userCache.isAuthenticated == true)+ this.clearUser();+ return(this.userCache);+ },++ clearUser: function () {+// alert('clearUser');+ this.setUser({ isAuthenticated: false,+ claims: {},+ token: null+ });+ }+ };++ service.userCacheInit();++ return service;+ }]);+ }+ |]+
+ Happstack/Authenticate/Core.hs view
@@ -0,0 +1,910 @@+{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, TypeFamilies, TypeSynonymInstances, UndecidableInstances, OverloadedStrings #-}+{-++A user is uniquely identified by their 'UserId'. A user can have one+or more authentication methods associated with their account. However,+each authentication method can only be associated with a single+'UserId'. This means, for example, that a user can not use the same+openid account to log in as multiple different users.++Additionally, it is assume that all authentication methods associated+with the 'UserId' are controlled by a single individual. They are not+intended to provide a way for several different users to share the+same account.++An email address is also collected to make account recovery easier.++Authentication Method+---------------------++When creating an account there are some common aspects -- such as the+username and email address. But we also want to allow the user to+select a method for authentication.++Creating the account could be multiple steps. What if we store the+partial data in a token. That way we avoid creating half-a-user.++From an API point of view -- we want the client to simple POST to+/users and create an account.++For different authentication backends, we need the user to be able to+fetch the partials for the extra information.++-}++module Happstack.Authenticate.Core+ ( AuthenticateConfig(..)+ , isAuthAdmin+ , usernameAcceptable+ , requireEmail+ , systemFromAddress+ , systemReplyToAddress+ , systemSendmailPath+ , postLoginRedirect+ , createUserCallback+ , HappstackAuthenticateI18N(..)+ , UserId(..)+ , unUserId+ , rUserId+ , succUserId+ , jsonOptions+ , toJSONResponse+ , toJSONSuccess+ , toJSONError+ , Username(..)+ , unUsername+ , rUsername+ , usernamePolicy+ , Email(..)+ , unEmail+ , User(..)+ , userId+ , username+ , email+ , UserIxs+ , IxUser+ , SharedSecret(..)+ , unSharedSecret+ , SimpleAddress(..)+ , genSharedSecret+ , genSharedSecretDevURandom+ , genSharedSecretSysRandom+ , SharedSecrets+ , initialSharedSecrets+ , CoreError(..)+ , NewAccountMode(..)+ , AuthenticateState(..)+ , sharedSecrets+ , users+ , nextUserId+ , defaultSessionTimeout+ , newAccountMode+ , initialAuthenticateState+ , SetSharedSecret(..)+ , GetSharedSecret(..)+ , SetDefaultSessionTimeout(..)+ , GetDefaultSessionTimeout(..)+ , SetNewAccountMode(..)+ , GetNewAccountMode(..)+ , CreateUser(..)+ , CreateAnonymousUser(..)+ , UpdateUser(..)+ , DeleteUser(..)+ , GetUserByUsername(..)+ , GetUserByUserId(..)+ , GetUserByEmail(..)+ , GetUsers(..)+ , GetUsersByEmail(..)+ , GetAuthenticateState(..)+ , getOrGenSharedSecret+ , Token(..)+ , tokenUser+ , tokenIsAuthAdmin+ , TokenText+ , issueToken+ , decodeAndVerifyToken+ , authCookieName+ , addTokenCookie+ , deleteTokenCookie+ , getTokenCookie+ , getTokenHeader+ , getToken+ , getUserId+ , AuthenticationMethod(..)+ , unAuthenticationMethod+ , rAuthenticationMethod+ , AuthenticationHandler+ , AuthenticationHandlers+ , AuthenticateURL(..)+ , rAuthenticationMethods+ , rControllers+ , systemFromAddress+ , systemReplyToAddress+ , systemSendmailPath+ , authenticateURL+ , nestAuthenticationMethod+ ) where++import Control.Applicative (Applicative(pure), Alternative, (<$>), optional)+import Control.Category ((.), id)+import Control.Exception (SomeException)+import qualified Control.Exception as E+import Control.Lens ((?=), (.=), (^.), (.~), makeLenses, view, set)+import Control.Lens.At (IxValue(..), Ixed(..), Index(..), At(at))+import Control.Monad.Trans (MonadIO(liftIO))+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put, modify)+import Data.Aeson (FromJSON(..), ToJSON(..), Result(..), fromJSON)+import qualified Data.Aeson as A+import Data.Aeson.Types (Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)+import Data.Acid (AcidState, Update, Query, makeAcidic)+import Data.Acid.Advanced (update', query')+import Data.ByteString.Base64 (encode)+import qualified Data.ByteString.Char8 as B+import Data.Data (Data, Typeable)+import Data.Default (def)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, maybeToList)+import Data.Monoid ((<>), mconcat, mempty)+import Data.SafeCopy (SafeCopy, Migrate(..), base, deriveSafeCopy, extension)+import Data.IxSet.Typed+import qualified Data.IxSet.Typed as IxSet+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)+import Data.UserId (UserId(..), rUserId, succUserId, unUserId)+import GHC.Generics (Generic)+import Happstack.Server (Cookie(secure), CookieLife(Session, MaxAge), Happstack, ServerPartT, Request(rqSecure), Response, addCookie, askRq, expireCookie, getHeaderM, lookCookie, lookCookieValue, mkCookie, notFound, toResponseBS)+-- import Happstack.Server.Internal.Clock (getApproximateUTCTime)+import Language.Javascript.JMacro+import Prelude hiding ((.), id, exp)+import System.IO (IOMode(ReadMode), withFile)+import System.Random (randomRIO)+import Text.Boomerang.TH (makeBoomerangs)+import Text.Shakespeare.I18N (RenderMessage(renderMessage), mkMessageFor)+import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, verify)+import qualified Web.JWT as JWT+#if MIN_VERSION_jwt(0,8,0)+import Web.JWT (ClaimsMap(..), hmacSecret)+#else+import Web.JWT (secret)+#endif++import Web.Routes (RouteT, PathInfo(..), nestURL)+import Web.Routes.Boomerang+import Web.Routes.Happstack ()+import Web.Routes.TH (derivePathInfo)++#if MIN_VERSION_jwt(0,8,0)+#else+unClaimsMap = id+#endif+++-- | when creating JSON field names, drop the first character. Since+-- we are using lens, the leading character should always be _.+jsonOptions :: Options+jsonOptions = defaultOptions { fieldLabelModifier = drop 1 }++data HappstackAuthenticateI18N = HappstackAuthenticateI18N++------------------------------------------------------------------------------+-- CoreError+------------------------------------------------------------------------------++-- | the `CoreError` type is used to represent errors in a language+-- agnostic manner. The errors are translated into human readable form+-- via the I18N translations.+data CoreError+ = HandlerNotFound -- AuthenticationMethod+ | URLDecodeFailed+ | UsernameAlreadyExists+ | AuthorizationRequired+ | Forbidden+ | JSONDecodeFailed+ | InvalidUserId+ | UsernameNotAcceptable+ | InvalidEmail+ | TextError Text+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+instance ToJSON CoreError where toJSON = genericToJSON jsonOptions+instance FromJSON CoreError where parseJSON = genericParseJSON jsonOptions++instance ToJExpr CoreError where+ toJExpr = toJExpr . toJSON++deriveSafeCopy 0 'base ''CoreError++mkMessageFor "HappstackAuthenticateI18N" "CoreError" "messages/core" ("en")++data Status+ = Ok+ | NotOk+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''Status+-- makeLenses ''Status+makeBoomerangs ''Status++instance ToJSON Status where toJSON = genericToJSON jsonOptions+instance FromJSON Status where parseJSON = genericParseJSON jsonOptions++data JSONResponse = JSONResponse+ { _jrStatus :: Status+ , _jrData :: A.Value+ }+ deriving (Eq, Read, Show, Data, Typeable, Generic)+-- deriveSafeCopy 1 'base ''JSONResponse+makeLenses ''JSONResponse+makeBoomerangs ''JSONResponse++instance ToJSON JSONResponse where toJSON = genericToJSON jsonOptions+instance FromJSON JSONResponse where parseJSON = genericParseJSON jsonOptions++-- | convert a value to a JSON encoded 'Response'+toJSONResponse :: (RenderMessage HappstackAuthenticateI18N e, ToJSON a) => Either e a -> Response+toJSONResponse (Left e) = toJSONError e+toJSONResponse (Right a) = toJSONSuccess a++-- | convert a value to a JSON encoded 'Response'+toJSONSuccess :: (ToJSON a) => a -> Response+toJSONSuccess a = toResponseBS "application/json" (A.encode (JSONResponse Ok (A.toJSON a)))++-- | convert an error to a JSON encoded 'Response'+--+-- FIXME: I18N+toJSONError :: forall e. (RenderMessage HappstackAuthenticateI18N e) => e -> Response+toJSONError e = toResponseBS "application/json" (A.encode (JSONResponse NotOk (A.toJSON (renderMessage HappstackAuthenticateI18N ["en"] e))))+-- (A.encode (A.object ["error" A..= renderMessage HappstackAuthenticateI18N ["en"] e]))++------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- UserId+------------------------------------------------------------------------------+{-+-- | a 'UserId' uniquely identifies a user.+newtype UserId = UserId { _unUserId :: Integer }+ deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''UserId+makeLenses ''UserId+makeBoomerangs ''UserId++instance ToJSON UserId where toJSON (UserId i) = toJSON i+instance FromJSON UserId where parseJSON v = UserId <$> parseJSON v++instance PathInfo UserId where+ toPathSegments (UserId i) = toPathSegments i+ fromPathSegments = UserId <$> fromPathSegments++-- | get the next `UserId`+succUserId :: UserId -> UserId+succUserId (UserId i) = UserId (succ i)+-}+------------------------------------------------------------------------------+-- Username+------------------------------------------------------------------------------++-- | an arbitrary, but unique string that the user uses to identify themselves+newtype Username = Username { _unUsername :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''Username+makeLenses ''Username+makeBoomerangs ''Username++instance ToJSON Username where toJSON (Username i) = toJSON i+instance FromJSON Username where parseJSON v = Username <$> parseJSON v++instance PathInfo Username where+ toPathSegments (Username t) = toPathSegments t+ fromPathSegments = Username <$> fromPathSegments++------------------------------------------------------------------------------+-- Email+------------------------------------------------------------------------------++-- | an `Email` address. No validation in performed.+newtype Email = Email { _unEmail :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''Email+makeLenses ''Email++instance ToJSON Email where toJSON (Email i) = toJSON i+instance FromJSON Email where parseJSON v = Email <$> parseJSON v++instance PathInfo Email where+ toPathSegments (Email t) = toPathSegments t+ fromPathSegments = Email <$> fromPathSegments++------------------------------------------------------------------------------+-- User+------------------------------------------------------------------------------++-- | A unique 'User'+data User = User+ { _userId :: UserId+ , _username :: Username+ , _email :: Maybe Email+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''User+makeLenses ''User++instance ToJSON User where toJSON = genericToJSON jsonOptions+instance FromJSON User where parseJSON = genericParseJSON jsonOptions++type UserIxs = '[UserId, Username, Email]+type IxUser = IxSet UserIxs User++instance Indexable UserIxs User where+ indices = ixList+ (ixFun $ (:[]) . view userId)+ (ixFun $ (:[]) . view username)+ (ixFun $ maybeToList . view email)++------------------------------------------------------------------------------+-- SimpleAddress+------------------------------------------------------------------------------++data SimpleAddress = SimpleAddress+ { _saName :: Maybe Text+ , _saEmail :: Email+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 0 'base ''SimpleAddress+makeLenses ''SimpleAddress++------------------------------------------------------------------------------+-- AuthenticateConfig+------------------------------------------------------------------------------++-- | Various configuration options that apply to all authentication methods+data AuthenticateConfig = AuthenticateConfig+ { _isAuthAdmin :: UserId -> IO Bool -- ^ can user administrate the authentication system?+ , _usernameAcceptable :: Username -> Maybe CoreError -- ^ enforce username policies, valid email, etc. 'Nothing' == ok, 'Just Text' == error message+ , _requireEmail :: Bool -- ^ require use to supply an email address when creating an account+ , _systemFromAddress :: Maybe SimpleAddress -- ^ From: line for emails sent by the server+ , _systemReplyToAddress :: Maybe SimpleAddress -- ^ Reply-To: line for emails sent by the server+ , _systemSendmailPath :: Maybe FilePath -- ^ path to sendmail if it is not \/usr\/sbin\/sendmail+ , _postLoginRedirect :: Maybe Text -- ^ path to redirect to after a successful login+ , _createUserCallback :: Maybe (User -> IO ()) -- ^ a function to call when a new user is created. Useful for adding them to mailing lists or other stuff+ }+ deriving (Typeable, Generic)+makeLenses ''AuthenticateConfig++-- | a very basic policy for 'userAcceptable'+--+-- Enforces:+--+-- 'Username' can not be empty+usernamePolicy :: Username+ -> Maybe CoreError+usernamePolicy username =+ if Text.null $ username ^. unUsername+ then Just UsernameNotAcceptable+ else Nothing++------------------------------------------------------------------------------+-- SharedSecret+------------------------------------------------------------------------------++-- | The shared secret is used to encrypt a users data on a per-user basis.+-- We can invalidate a JWT value by changing the shared secret.+newtype SharedSecret = SharedSecret { _unSharedSecret :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''SharedSecret+makeLenses ''SharedSecret++-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the+-- system RNG as a fallback. This is the function used to generate salts by+-- 'makePassword'.+genSharedSecret :: (MonadIO m) => m SharedSecret+genSharedSecret = liftIO $ E.catch genSharedSecretDevURandom (\(_::SomeException) -> genSharedSecretSysRandom)++-- | Generate a 'SharedSecret' from @\/dev\/urandom@.+--+-- see: `genSharedSecret`+genSharedSecretDevURandom :: IO SharedSecret+genSharedSecretDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do+ secret <- B.hGet h 32+ return $ SharedSecret . Text.decodeUtf8 . encode $ secret++-- | Generate a 'SharedSecret' from 'System.Random'.+--+-- see: `genSharedSecret`+genSharedSecretSysRandom :: IO SharedSecret+genSharedSecretSysRandom = randomChars >>= return . SharedSecret . Text.decodeUtf8 . encode . B.pack+ where randomChars = sequence $ replicate 32 $ randomRIO ('\NUL', '\255')++------------------------------------------------------------------------------+-- SharedSecrets+------------------------------------------------------------------------------++-- | A map which stores the `SharedSecret` for each `UserId`+type SharedSecrets = Map UserId SharedSecret++-- | An empty `SharedSecrets`+initialSharedSecrets :: SharedSecrets+initialSharedSecrets = Map.empty++------------------------------------------------------------------------------+-- NewAccountMode+------------------------------------------------------------------------------++-- | This value is used to configure the type of new user registrations+-- permitted for this system.+data NewAccountMode+ = OpenRegistration -- ^ new users can create their own accounts+ | ModeratedRegistration -- ^ new users can apply to create their own accounts, but a moderator must approve them before they are active+ | ClosedRegistration -- ^ only the admin can create a new account+ deriving (Eq, Show, Typeable, Generic)+deriveSafeCopy 1 'base ''NewAccountMode++------------------------------------------------------------------------------+-- AuthenticateState+------------------------------------------------------------------------------++-- | this acid-state value contains the state common to all+-- authentication methods+data AuthenticateState = AuthenticateState+ { _sharedSecrets :: SharedSecrets+ , _users :: IxUser+ , _nextUserId :: UserId+ , _defaultSessionTimeout :: Int -- ^ default session time out in seconds+ , _newAccountMode :: NewAccountMode+ }+ deriving (Eq, Show, Typeable, Generic)+deriveSafeCopy 1 'base ''AuthenticateState+makeLenses ''AuthenticateState++-- | a reasonable initial 'AuthenticateState'+initialAuthenticateState :: AuthenticateState+initialAuthenticateState = AuthenticateState+ { _sharedSecrets = initialSharedSecrets+ , _users = IxSet.empty+ , _nextUserId = UserId 1+ , _defaultSessionTimeout = 60*60+ , _newAccountMode = OpenRegistration+ }++------------------------------------------------------------------------------+-- SharedSecrets AcidState Methods+------------------------------------------------------------------------------++-- | set the 'SharedSecret' for 'UserId' overwritten any previous secret.+setSharedSecret :: UserId+ -> SharedSecret+ -> Update AuthenticateState ()+setSharedSecret userId sharedSecret =+ sharedSecrets . at userId ?= sharedSecret++-- | get the 'SharedSecret' for 'UserId'+getSharedSecret :: UserId+ -> Query AuthenticateState (Maybe SharedSecret)+getSharedSecret userId =+ view (sharedSecrets . at userId)++------------------------------------------------------------------------------+-- SessionTimeout AcidState Methods+------------------------------------------------------------------------------++-- | set the default inactivity timeout for new sessions+setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180)+ -> Update AuthenticateState ()+setDefaultSessionTimeout newTimeout =+ modify $ \as@AuthenticateState{..} -> as { _defaultSessionTimeout = newTimeout }++-- | set the default inactivity timeout for new sessions+getDefaultSessionTimeout :: Query AuthenticateState Int+getDefaultSessionTimeout =+ view defaultSessionTimeout <$> ask++------------------------------------------------------------------------------+-- NewAccountMode AcidState Methods+------------------------------------------------------------------------------++-- | set the 'NewAccountMode'+setNewAccountMode :: NewAccountMode+ -> Update AuthenticateState ()+setNewAccountMode mode =+ newAccountMode .= mode++-- | get the 'NewAccountMode'+getNewAccountMode :: Query AuthenticateState NewAccountMode+getNewAccountMode =+ view newAccountMode++------------------------------------------------------------------------------+-- User related AcidState Methods+------------------------------------------------------------------------------++-- | Create a new 'User'. This will allocate a new 'UserId'. The+-- returned 'User' value will have the updated 'UserId'.+createUser :: User+ -> Update AuthenticateState (Either CoreError User)+createUser u =+ do as@AuthenticateState{..} <- get+ if IxSet.null $ (as ^. users) @= (u ^. username)+ then do let user' = set userId _nextUserId u+ as' = as { _users = IxSet.insert user' _users+ , _nextUserId = succ _nextUserId+ }+ put as'+ return (Right user')+ else+ return (Left UsernameAlreadyExists)++-- | Create a new 'User'. This will allocate a new 'UserId'. The+-- returned 'User' value will have the updated 'UserId'.+createAnonymousUser :: Update AuthenticateState User+createAnonymousUser =+ do as@AuthenticateState{..} <- get+ let user = User { _userId = _nextUserId+ , _username = Username ("Anonymous " <> Text.pack (show _nextUserId))+ , _email = Nothing+ }+ as' = as { _users = IxSet.insert user _users+ , _nextUserId = succ _nextUserId+ }+ put as'+ return user++-- | Update an existing 'User'. Must already have a valid 'UserId'.+updateUser :: User+ -> Update AuthenticateState ()+updateUser u =+ do as@AuthenticateState{..} <- get+ let as' = as { _users = IxSet.updateIx (u ^. userId) u _users+ }+ put as'++-- | Delete 'User' with the specified 'UserId'+deleteUser :: UserId+ -> Update AuthenticateState ()+deleteUser uid =+ do as@AuthenticateState{..} <- get+ let as' = as { _users = IxSet.deleteIx uid _users+ }+ put as'++-- | look up a 'User' by their 'Username'+getUserByUsername :: Username+ -> Query AuthenticateState (Maybe User)+getUserByUsername username =+ do us <- view users+ return $ getOne $ us @= username++-- | look up a 'User' by their 'UserId'+getUserByUserId :: UserId+ -> Query AuthenticateState (Maybe User)+getUserByUserId userId =+ do us <- view users+ return $ getOne $ us @= userId++-- | find all 'Users'+--+getUsers :: Query AuthenticateState (Set User)+getUsers =+ do us <- view users+ return $ toSet $ us++-- | look up a 'User' by their 'Email'+--+-- NOTE: if the email is associated with more than one account this will return 'Nothing'+getUserByEmail :: Email+ -> Query AuthenticateState (Maybe User)+getUserByEmail email =+ do us <- view users+ return $ getOne $ us @= email++-- | find all 'Users' which match 'Email'+--+getUsersByEmail :: Email+ -> Query AuthenticateState (Set User)+getUsersByEmail email =+ do us <- view users+ return $ toSet $ us @= email++-- | get the entire AuthenticateState value+getAuthenticateState :: Query AuthenticateState AuthenticateState+getAuthenticateState = ask++makeAcidic ''AuthenticateState+ [ 'setDefaultSessionTimeout+ , 'getDefaultSessionTimeout+ , 'setSharedSecret+ , 'getSharedSecret+ , 'setNewAccountMode+ , 'getNewAccountMode+ , 'createUser+ , 'createAnonymousUser+ , 'updateUser+ , 'deleteUser+ , 'getUserByUsername+ , 'getUserByUserId+ , 'getUsers+ , 'getUserByEmail+ , 'getUsersByEmail+ , 'getAuthenticateState+ ]++------------------------------------------------------------------------------+-- Shared Secret Functions+------------------------------------------------------------------------------++-- | get the 'SharedSecret' for 'UserId'. Generate one if they don't have one yet.+getOrGenSharedSecret :: (MonadIO m) =>+ AcidState AuthenticateState+ -> UserId+ -> m (SharedSecret)+getOrGenSharedSecret authenticateState uid =+ do mSSecret <- query' authenticateState (GetSharedSecret uid)+ case mSSecret of+ (Just ssecret) -> return ssecret+ Nothing -> do+ ssecret <- genSharedSecret+ update' authenticateState (SetSharedSecret uid ssecret)+ return ssecret++------------------------------------------------------------------------------+-- Token Functions+------------------------------------------------------------------------------++-- | The `Token` type represents the encrypted data used to identify a+-- user.+data Token = Token+ { _tokenUser :: User+ , _tokenIsAuthAdmin :: Bool+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''Token+instance ToJSON Token where toJSON = genericToJSON jsonOptions+instance FromJSON Token where parseJSON = genericParseJSON jsonOptions++-- | `TokenText` is the encrypted form of the `Token` which is passed+-- between the server and the client.+type TokenText = Text++-- | create a `Token` for `User`+--+-- The @isAuthAdmin@ paramater is a function which will be called to+-- determine if `UserId` is a user who should be given Administrator+-- privileges. This includes the ability to things such as set the+-- `OpenId` realm, change the registeration mode, etc.+issueToken :: (MonadIO m) =>+ AcidState AuthenticateState+ -> AuthenticateConfig+ -> User -- ^ the user+ -> m TokenText+issueToken authenticateState authenticateConfig user =+ do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId)+ admin <- liftIO $ (authenticateConfig ^. isAuthAdmin) (user ^. userId)+ now <- liftIO getCurrentTime+ let claims = JWTClaimsSet+ { iss = Nothing+ , sub = Nothing+ , aud = Nothing+ , exp = intDate $ utcTimeToPOSIXSeconds (addUTCTime (60*60*24*30) now)+ , nbf = Nothing+ , iat = Nothing+ , jti = Nothing+ , unregisteredClaims =+#if MIN_VERSION_jwt(0,8,0)+ ClaimsMap $+#endif+ Map.fromList [ ("user" , toJSON user)+ , ("authAdmin", toJSON admin)+ ]+ }+#if MIN_VERSION_jwt(0,10,0)+ return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims+#elif MIN_VERSION_jwt(0,9,0)+ return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims+#else+ return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims+#endif++-- | decode and verify the `TokenText`. If successful, return the+-- `Token` otherwise `Nothing`.+decodeAndVerifyToken :: (MonadIO m) =>+ AcidState AuthenticateState+ -> UTCTime+ -> TokenText+ -> m (Maybe (Token, JWT VerifiedJWT))+decodeAndVerifyToken authenticateState now token =+ do -- decode unverified token+ let mUnverified = decode token+ case mUnverified of+ Nothing -> return Nothing+ (Just unverified) ->+ -- check that token has user claim+ case Map.lookup "user" (unClaimsMap (unregisteredClaims (claims unverified))) of+ Nothing -> return Nothing+ (Just uv) ->+ -- decode user json value+ case fromJSON uv of+ (Error _) -> return Nothing+ (Success u) ->+ do -- get the shared secret for userId+ mssecret <- query' authenticateState (GetSharedSecret (u ^. userId))+ case mssecret of+ Nothing -> return Nothing+ (Just ssecret) ->+ -- finally we can verify all the claims+#if MIN_VERSION_jwt(0,11,0)+ case verify (JWT.toVerify $ hmacSecret (_unSharedSecret ssecret)) unverified of+#elif MIN_VERSION_jwt(0,8,0)+ case verify (hmacSecret (_unSharedSecret ssecret)) unverified of+#else+ case verify (secret (_unSharedSecret ssecret)) unverified of+#endif+ Nothing -> return Nothing+ (Just verified) -> -- check expiration+ case exp (claims verified) of+ -- exp field missing, expire now+ Nothing -> return Nothing+ (Just exp') ->+ if (utcTimeToPOSIXSeconds now) > (secondsSinceEpoch exp')+ then return Nothing+ else case Map.lookup "authAdmin" (unClaimsMap (unregisteredClaims (claims verified))) of+ Nothing -> return (Just (Token u False, verified))+ (Just a) ->+ case fromJSON a of+ (Error _) -> return (Just (Token u False, verified))+ (Success b) -> return (Just (Token u b, verified))++------------------------------------------------------------------------------+-- Token in a Cookie+------------------------------------------------------------------------------++-- | name of the `Cookie` used to hold the `TokenText`+authCookieName :: String+authCookieName = "atc"++-- | create a `Token` for `User` and add a `Cookie` to the `Response`+--+-- see also: `issueToken`+addTokenCookie :: (Happstack m) =>+ AcidState AuthenticateState+ -> AuthenticateConfig+ -> User+ -> m TokenText+addTokenCookie authenticateState authenticateConfig user =+ do token <- issueToken authenticateState authenticateConfig user+ s <- rqSecure <$> askRq -- FIXME: this isn't that accurate in the face of proxies+ addCookie (MaxAge (60*60*24*30)) ((mkCookie authCookieName (Text.unpack token)) { secure = s })+-- addCookie (MaxAge 60) ((mkCookie authCookieName (Text.unpack token)) { secure = s })+ return token++-- | delete the `Token` `Cookie`+deleteTokenCookie :: (Happstack m) =>+ m ()+deleteTokenCookie =+ expireCookie authCookieName+++-- | get, decode, and verify the `Token` from the `Cookie`.+getTokenCookie :: (Happstack m) =>+ AcidState AuthenticateState+ -> m (Maybe (Token, JWT VerifiedJWT))+getTokenCookie authenticateState =+ do mToken <- optional $ lookCookieValue authCookieName+ case mToken of+ Nothing -> return Nothing+ (Just token) ->+ do now <- liftIO getCurrentTime+ decodeAndVerifyToken authenticateState now (Text.pack token)+++------------------------------------------------------------------------------+-- Token in a Header+------------------------------------------------------------------------------++-- | get, decode, and verify the `Token` from the @Authorization@ HTTP header+getTokenHeader :: (Happstack m) =>+ AcidState AuthenticateState+ -> m (Maybe (Token, JWT VerifiedJWT))+getTokenHeader authenticateState =+ do mAuth <- getHeaderM "Authorization"+ case mAuth of+ Nothing -> return Nothing+ (Just auth') ->+ do let auth = B.drop 7 auth'+ now <- liftIO getCurrentTime+ decodeAndVerifyToken authenticateState now (Text.decodeUtf8 auth)++------------------------------------------------------------------------------+-- Token in a Header or Cookie+------------------------------------------------------------------------------++-- | get, decode, and verify the `Token` looking first in the+-- @Authorization@ header and then in `Cookie`.+--+-- see also: `getTokenHeader`, `getTokenCookie`+getToken :: (Happstack m) =>+ AcidState AuthenticateState+ -> m (Maybe (Token, JWT VerifiedJWT))+getToken authenticateState =+ do mToken <- getTokenHeader authenticateState+ case mToken of+ Nothing -> getTokenCookie authenticateState+ (Just token) -> return (Just token)++------------------------------------------------------------------------------+-- helper function: calls `getToken` but only returns the `UserId`+------------------------------------------------------------------------------++-- | get the `UserId`+--+-- calls `getToken` but returns only the `UserId`+getUserId :: (Happstack m) =>+ AcidState AuthenticateState+ -> m (Maybe UserId)+getUserId authenticateState =+ do mToken <- getToken authenticateState+ case mToken of+ Nothing -> return Nothing+ (Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId)+++------------------------------------------------------------------------------+-- AuthenticationMethod+------------------------------------------------------------------------------++-- | `AuthenticationMethod` is used by the routing system to select which+-- authentication backend should handle this request.+newtype AuthenticationMethod = AuthenticationMethod+ { _unAuthenticationMethod :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+derivePathInfo ''AuthenticationMethod+deriveSafeCopy 1 'base ''AuthenticationMethod+makeLenses ''AuthenticationMethod+makeBoomerangs ''AuthenticationMethod++instance ToJSON AuthenticationMethod where toJSON (AuthenticationMethod method) = toJSON method+instance FromJSON AuthenticationMethod where parseJSON v = AuthenticationMethod <$> parseJSON v++type AuthenticationHandler = [Text] -> RouteT AuthenticateURL (ServerPartT IO) Response++type AuthenticationHandlers = Map AuthenticationMethod AuthenticationHandler++------------------------------------------------------------------------------+-- AuthenticationURL+------------------------------------------------------------------------------++data AuthenticateURL+ = -- Users (Maybe UserId)+ AuthenticationMethods (Maybe (AuthenticationMethod, [Text]))+ | Controllers+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++makeBoomerangs ''AuthenticateURL++-- | a `Router` for `AuthenicateURL`+authenticateURL :: Router () (AuthenticateURL :- ())+authenticateURL =+ ( -- "users" </> ( rUsers . rMaybe userId )+ "authentication-methods" </> ( rAuthenticationMethods . rMaybe authenticationMethod)+ <> "controllers" . rControllers+ )+ where+ userId = rUserId . integer+ authenticationMethod = rPair . (rAuthenticationMethod . anyText) </> (rListSep anyText eos)++instance PathInfo AuthenticateURL where+ fromPathSegments = boomerangFromPathSegments authenticateURL+ toPathSegments = boomerangToPathSegments authenticateURL++-- | helper function which converts a URL for an authentication+-- backend into an `AuthenticateURL`.+nestAuthenticationMethod :: (PathInfo methodURL) =>+ AuthenticationMethod+ -> RouteT methodURL m a+ -> RouteT AuthenticateURL m a+nestAuthenticationMethod authenticationMethod =+ nestURL $ \methodURL -> AuthenticationMethods $ Just (authenticationMethod, toPathSegments methodURL)+
+ Happstack/Authenticate/OpenId/Controllers.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+module Happstack.Authenticate.OpenId.Controllers where++import Control.Lens ((^.))+import Control.Monad.Trans (MonadIO(..))+import Data.Acid (AcidState)+import Data.Acid.Advanced (query')+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, getToken, tokenIsAuthAdmin)+import Happstack.Authenticate.OpenId.Core (GetOpenIdRealm(..), OpenIdState)+import Happstack.Authenticate.OpenId.URL (OpenIdURL(BeginDance, Partial, ReturnTo), nestOpenIdURL)+import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(UsingYahoo, RealmForm))+import Happstack.Server (Happstack)+import Language.Javascript.JMacro+import Web.Routes++openIdCtrl+ :: (Happstack m) =>+ AcidState AuthenticateState+ -> AcidState OpenIdState+ -> RouteT AuthenticateURL m JStat+openIdCtrl authenticateState openIdState =+ nestOpenIdURL $+ do fn <- askRouteFn+ mt <- getToken authenticateState+ mRealm <- case mt of+ (Just (token, _))+ | token ^. tokenIsAuthAdmin ->+ query' openIdState GetOpenIdRealm+ | otherwise -> return Nothing+ Nothing -> return Nothing+ return $ openIdCtrlJs mRealm fn++openIdCtrlJs+ :: Maybe Text+ -> (OpenIdURL -> [(Text, Maybe Text)] -> Text)+ -> JStat+openIdCtrlJs mRealm showURL =+ [jmacro|+ var openId = angular.module('openId', ['happstackAuthentication']);+ var openIdWindow;+ tokenCB = function (token) { alert('tokenCB: ' + token); };++ openId.controller('OpenIdCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService)+ { $scope.openIdRealm = { srOpenIdRealm: `(fromMaybe "" mRealm)` };++ $scope.openIdWindow = function (providerUrl) {+ tokenCB = function(token) { var u = userService.updateFromToken(token); $scope.isAuthenticated = u.isAuthenticated; $scope.$apply(); };+ openIdWindow = window.open(providerUrl, "_blank", "toolbar=0");+ };++ $scope.setOpenIdRealm = function (setRealmUrl) {+ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.username_password_error = 'error communicating with the server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.set_openid_realm_msg = 'Realm Updated.'; // FIXME -- I18N+// $scope.openIdRealm = '';+ } else {+ $scope.set_open_id_realm_msg = datum.jrData;+ }+ }+ };++ $http.post(setRealmUrl, $scope.openIdRealm).+ success(callback).+ error(callback);+ };+ }]);++ openId.directive('openidYahoo', ['$rootScope', function ($rootScope) {+ return {+ restrict: 'E',+ replace: true,+ templateUrl: `(showURL (Partial UsingYahoo) [])`+ };+ }]);++ openId.directive('openidRealm', ['$rootScope', function ($rootScope) {+ return {+ restrict: 'E',+ templateUrl: `(showURL (Partial RealmForm) [])`+ };+ }]);+ |]
+ Happstack/Authenticate/OpenId/Core.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell, TypeFamilies #-}+module Happstack.Authenticate.OpenId.Core where++import Control.Applicative (Alternative)+import Control.Monad (msum)+import Control.Lens ((?=), (^.), (.=), makeLenses, view, at)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Acid (AcidState, Query, Update, makeAcidic)+import Data.Acid.Advanced (query', update')+import qualified Data.Aeson as Aeson+import Data.Aeson (Object(..), Value(..), decode, encode)+import Data.Aeson.Types (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)+import Data.Data (Data, Typeable)+import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.SafeCopy (Migrate(..), SafeCopy, base, extension, deriveSafeCopy)+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Map as Map+import Data.UserId (UserId)+import GHC.Generics (Generic)+import Happstack.Authenticate.Core (AuthenticateConfig(..), AuthenticateState, CoreError(..), CreateAnonymousUser(..), GetUserByUserId(..), HappstackAuthenticateI18N(..), addTokenCookie, getToken, jsonOptions, toJSONError, toJSONSuccess, toJSONResponse, tokenIsAuthAdmin, userId)+import Happstack.Authenticate.OpenId.URL+import Happstack.Server (RqBody(..), Happstack, Method(..), Response, askRq, unauthorized, badRequest, internalServerError, forbidden, lookPairsBS, method, resp, takeRequestBody, toResponse, toResponseBS, ok)+import Language.Javascript.JMacro+import Network.HTTP.Conduit (newManager, tlsManagerSettings)+import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor)+import Web.Authenticate.OpenId (Identifier)+import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl)++{-++The OpenId authentication scheme works as follows:++ - the user tells us which OpenId provider they want to use+ - we call 'getForwardUrl' to construct a url for that provider+ - the user is redirected to that 'url' -- typically a 3rd party site+ - the user interacts with site to confirm the login+ - that site redirects the user back to a url at our site with some 'claims' in the query string+ - we then talk to the user's OpenId server and verify those claims+ - we know have a verified OpenId identifier for the user++-}++$(deriveSafeCopy 1 'base ''Identifier)++------------------------------------------------------------------------------+-- OpenIdError+------------------------------------------------------------------------------++data OpenIdError+ = UnknownIdentifier+ | CoreError { openIdErrorMessageE :: CoreError }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+instance ToJSON OpenIdError where toJSON = genericToJSON jsonOptions+instance FromJSON OpenIdError where parseJSON = genericParseJSON jsonOptions++instance ToJExpr OpenIdError where+ toJExpr = toJExpr . toJSON++mkMessageFor "HappstackAuthenticateI18N" "OpenIdError" "messages/openid/error" ("en")++------------------------------------------------------------------------------+-- OpenIdState+------------------------------------------------------------------------------++data OpenIdState_1 = OpenIdState_1+ { _identifiers_1 :: Map Identifier UserId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''OpenIdState_1+makeLenses ''OpenIdState_1++data OpenIdState = OpenIdState+ { _identifiers :: Map Identifier UserId+ , _openIdRealm :: Maybe Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++instance Migrate OpenIdState where+ type MigrateFrom OpenIdState = OpenIdState_1+ migrate (OpenIdState_1 ids) = OpenIdState ids Nothing++deriveSafeCopy 2 'extension ''OpenIdState+makeLenses ''OpenIdState+++initialOpenIdState :: OpenIdState+initialOpenIdState = OpenIdState+ { _identifiers = Map.fromList []+ , _openIdRealm = Nothing+ }++------------------------------------------------------------------------------+-- 'OpenIdState' acid-state methods+------------------------------------------------------------------------------++identifierToUserId :: Identifier -> Query OpenIdState (Maybe UserId)+identifierToUserId identifier = view (identifiers . at identifier)++associateIdentifierWithUserId :: Identifier -> UserId -> Update OpenIdState ()+associateIdentifierWithUserId ident uid =+ identifiers . at ident ?= uid++-- | Get the OpenId realm to use for authentication+getOpenIdRealm :: Query OpenIdState (Maybe Text)+getOpenIdRealm = view openIdRealm++-- | set the realm used for OpenId Authentication+--+-- IMPORTANT: Changing this value after users have registered is+-- likely to invalidate existing OpenId tokens resulting in users no+-- longer being able to access their old accounts.+setOpenIdRealm :: Maybe Text+ -> Update OpenIdState ()+setOpenIdRealm realm = openIdRealm .= realm++makeAcidic ''OpenIdState+ [ 'identifierToUserId+ , 'associateIdentifierWithUserId+ , 'getOpenIdRealm+ , 'setOpenIdRealm+ ]++data SetRealmData = SetRealmData+ { _srOpenIdRealm :: Maybe Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''SetRealmData+instance ToJSON SetRealmData where toJSON = genericToJSON jsonOptions+instance FromJSON SetRealmData where parseJSON = genericParseJSON jsonOptions++realm :: (Happstack m) =>+ AcidState AuthenticateState+ -> AcidState OpenIdState+ -> m Response+realm authenticateState openIdState =+ do mt <- getToken authenticateState+ case mt of+ Nothing -> unauthorized $ toJSONError (CoreError AuthorizationRequired)+ (Just (token,_))+ | token ^. tokenIsAuthAdmin == False -> forbidden $ toJSONError (CoreError Forbidden)+ | otherwise ->+ msum [ do method GET+ mRealm <- query' openIdState GetOpenIdRealm+ ok $ toJSONSuccess mRealm+ , do method POST+ ~(Just (Body body)) <- takeRequestBody =<< askRq+ case Aeson.decode body of+ Nothing -> badRequest $ toJSONError (CoreError JSONDecodeFailed)+ (Just (SetRealmData mRealm)) ->+ do -- liftIO $ putStrLn $ "mRealm from JSON: " ++ show mRealm+ update' openIdState (SetOpenIdRealm mRealm)+ ok $ toJSONSuccess ()+ ]++-- 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 $ do manager <- newManager tlsManagerSettings+ authenticateClaimed pairs manager+ return (oirOpLocal oir)++token :: (Alternative m, Happstack m) =>+ AcidState AuthenticateState+ -> AuthenticateConfig+ -> AcidState OpenIdState+ -> m Response+token authenticateState authenticateConfig openIdState =+ do identifier <- getIdentifier+ mUserId <- query' openIdState (IdentifierToUserId identifier)+ mUser <- case mUserId of+ Nothing -> -- badRequest $ toJSONError UnknownIdentifier+ do user <- update' authenticateState CreateAnonymousUser+ update' openIdState (AssociateIdentifierWithUserId identifier (user ^. userId))+-- addTokenCookie authenticateState user+ return (Just user)+ (Just uid) ->+ do mu <- query' authenticateState (GetUserByUserId uid)+ case mu of+ Nothing -> return Nothing+ (Just u) ->+ return (Just u)+ case mUser of+ Nothing -> internalServerError $ toJSONError $ CoreError InvalidUserId+ (Just user) -> do token <- addTokenCookie authenticateState authenticateConfig user+ let tokenBS = TL.encodeUtf8 $ TL.fromStrict token+-- ok $ toResponse token+ ok $ toResponseBS "text/html" $ "<html><head><script type='text/javascript'>window.opener.tokenCB('" <> tokenBS <> "'); window.close();</script></head><body></body></html>"++-- liftIO $ print token+-- ok $ toResponseBS "text/html" $ "<html><head><script type='text/javascript'>localStorage.setItem('user',</script></head><body>wheee</body></html>"+ {-+ do token <- addTokenCookie authenticateState u+ resp 201 $ toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)]+-}+{-+account :: (Happstack m) =>+ AcidState AuthenticateState+ -> AcidState OpenIdState+ -> Maybe (UserId, AccountURL)+ -> m (Either OpenIdError UserId)+-- handle new account created via POST to /account+account authenticateState openIdState Nothing =+ undefined+-}+{-+++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)++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)++-}
+ Happstack/Authenticate/OpenId/Partials.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-}+module Happstack.Authenticate.OpenId.Partials where++import Control.Category ((.), id)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans (MonadIO(..), lift)+import Data.Acid (AcidState)+import Data.Acid.Advanced (query')+import Data.Data (Data, Typeable)+import Data.Monoid ((<>))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.UserId (UserId)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LT+import HSP+import Happstack.Server.HSP.HTML ()+import Language.Haskell.HSX.QQ (hsx)+import Language.Javascript.JMacro+import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken)+import Happstack.Authenticate.OpenId.Core (OpenIdState(..), GetOpenIdRealm(..))+import Happstack.Authenticate.OpenId.URL (OpenIdURL(..), nestOpenIdURL)+import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(..))+import Happstack.Server (Happstack, unauthorized)+import Happstack.Server.XMLGenT ()+import HSP.JMacro ()+import Prelude hiding ((.), id)+import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage)+import Web.Authenticate.OpenId.Providers (yahoo)+import Web.Routes+import Web.Routes.XMLGenT ()+import Web.Routes.TH (derivePathInfo)++type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m))+type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m))++data PartialMsgs+ = UsingYahooMsg+ | SetRealmMsg+ | OpenIdRealmMsg++mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/openid/partials" "en"++instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where+ asChild msg =+ do lang <- ask+ asChild $ renderMessage HappstackAuthenticateI18N lang msg++instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where+ asAttr (k := v) =+ do lang <- ask+ asAttr (k := renderMessage HappstackAuthenticateI18N lang v)++routePartial+ :: (Functor m, Monad m, Happstack m) =>+ AcidState AuthenticateState+ -> AcidState OpenIdState+ -> PartialURL+ -> Partial m XML+routePartial authenticateState openIdState url =+ case url of+ UsingYahoo -> usingYahoo+ RealmForm -> realmForm openIdState++usingYahoo :: (Functor m, Monad m) =>+ Partial m XML+usingYahoo =+ do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack yahoo))+ [hsx|+ <a ng-click=("openIdWindow('" <> danceURL <> "')")><img src="https://raw.githubusercontent.com/Happstack/authbuttons/master/png/yahoo_32.png" alt=UsingYahooMsg /></a>+ |]++realmForm+ :: (Functor m, MonadIO m) =>+ AcidState OpenIdState+ -> Partial m XML+realmForm openIdState =+ do url <- lift $ nestOpenIdURL $ showURL Realm+ let setOpenIdRealmFn = "setOpenIdRealm('" <> url <> "')"+ [hsx|+ <div ng-show="claims.authAdmin">+ <form ng-submit=setOpenIdRealmFn role="form">+ <div class="form-group">{{set_openid_realm_msg}}</div>+ <div class="form-group">+ <label for="openid-realm"><% OpenIdRealmMsg %></label>+ <input class="form-control" ng-model="openIdRealm.srOpenIdRealm" type="text" id="openid-realm" name="openIdRealm" />+ </div>+ <div class="form-group">+ <input class="form-control" type="submit" value=SetRealmMsg />+ </div>+ </form>+ </div>+ |]
+ Happstack/Authenticate/OpenId/PartialsURL.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeOperators, OverloadedStrings #-}+module Happstack.Authenticate.OpenId.PartialsURL where++import Data.Data (Data, Typeable)+import Control.Category ((.), id)+import GHC.Generics (Generic)+import Prelude hiding ((.), id)+import Text.Boomerang.TH (makeBoomerangs)+import Web.Routes (PathInfo(..))+import Web.Routes.Boomerang (Router, (:-), (<>), boomerangFromPathSegments, boomerangToPathSegments)++data PartialURL+ = UsingYahoo+ | RealmForm+ deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)++makeBoomerangs ''PartialURL++partialURL :: Router () (PartialURL :- ())+partialURL =+ ( "using-yahoo" . rUsingYahoo+ <> "realm" . rRealmForm+ )++instance PathInfo PartialURL where+ fromPathSegments = boomerangFromPathSegments partialURL+ toPathSegments = boomerangToPathSegments partialURL
+ Happstack/Authenticate/OpenId/Route.hs view
@@ -0,0 +1,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)+
+ Happstack/Authenticate/OpenId/URL.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators, OverloadedStrings #-}+module Happstack.Authenticate.OpenId.URL where++import Control.Category ((.), id)+import Data.Data (Data, Typeable)+import Data.Text (Text)+import Data.UserId (UserId, rUserId)+import GHC.Generics (Generic)+import Prelude hiding ((.), id)+import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), nestAuthenticationMethod)+import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(..), partialURL)+import Text.Boomerang.TH (makeBoomerangs)+import Web.Routes (PathInfo(..), RouteT(..))+import Web.Routes.TH (derivePathInfo)+import Web.Routes.Boomerang++------------------------------------------------------------------------------+-- openIdAuthenticationMethod+------------------------------------------------------------------------------++openIdAuthenticationMethod :: AuthenticationMethod+openIdAuthenticationMethod = AuthenticationMethod "openId"++------------------------------------------------------------------------------+-- OpenIdURL+------------------------------------------------------------------------------++data OpenIdURL+ = Partial PartialURL+ | BeginDance Text+ | ReturnTo+ | Realm+ deriving (Eq, Ord, Data, Typeable, Generic, Read, Show)++makeBoomerangs ''OpenIdURL++openIdURL :: Router () (OpenIdURL :- ())+openIdURL =+ ( "partial" </> rPartial . partialURL+ <> "begin-dance" </> rBeginDance . anyText+ <> "return-to" </> rReturnTo+ <> "realm" </> rRealm+ )++instance PathInfo OpenIdURL where+ fromPathSegments = boomerangFromPathSegments openIdURL+ toPathSegments = boomerangToPathSegments openIdURL++-- showOpenIdURL :: (MonadRoute m) => OpenIdURL -> m Text+nestOpenIdURL :: RouteT OpenIdURL m a -> RouteT AuthenticateURL m a+nestOpenIdURL =+ nestAuthenticationMethod openIdAuthenticationMethod+
+ Happstack/Authenticate/Password/Controllers.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE QuasiQuotes #-}+module Happstack.Authenticate.Password.Controllers where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, readTVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Maybe (isJust, fromJust)+import Data.Text (Text)+import qualified Data.Text as T+import Happstack.Authenticate.Core (AuthenticateConfig(_postLoginRedirect), AuthenticateURL)+import Happstack.Authenticate.Password.URL (PasswordURL(Account, Token, Partial, PasswordReset, PasswordRequestReset), nestPasswordURL)+import Happstack.Authenticate.Password.PartialsURL (PartialURL(ChangePassword, Logout, Login, LoginInline, SignupPassword, ResetPasswordForm, RequestResetPasswordForm))+import Language.Javascript.JMacro+import Web.Routes++usernamePasswordCtrl :: (MonadIO m) => TVar AuthenticateConfig -> RouteT AuthenticateURL m JStat+usernamePasswordCtrl authenticateConfigTV =+ nestPasswordURL $+ do fn <- askRouteFn+ plr <- liftIO (_postLoginRedirect <$> (atomically $ readTVar authenticateConfigTV))+ return $ usernamePasswordCtrlJs plr fn++usernamePasswordCtrlJs :: Maybe Text -> (PasswordURL -> [(Text, Maybe Text)] -> Text) -> JStat+usernamePasswordCtrlJs postLoginRedirect showURL = [jmacro|+ {+ var usernamePassword = angular.module('usernamePassword', ['happstackAuthentication']);++ usernamePassword.controller('UsernamePasswordCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService) {++ // login()+ emptyUser = function() {+ return { user: '',+ password: ''+ };+ };++ $scope.user = emptyUser();+ $scope.login = function () {+ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.username_password_error = 'error communicating with the server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.username_password_error = '';+ userService.updateFromToken(datum.jrData.token);+ `loginRedirect postLoginRedirect`+ } else {+ userService.clearUser();+ $scope.username_password_error = datum.jrData;+ }+ }+ };+ $http.+ post(`(showURL Token [])`, $scope.user).+ success(callback).+ error(callback);+ };++ // signupPassword()+ emptySignup = function () {+ return { naUser: { username: '',+ email: ''+ },+ naPassword: '',+ naPasswordConfirm: ''+ };+ };+ $scope.signup = emptySignup();++ $scope.signupPassword = function () {+ $scope.signup.naUser.userId = 0;++ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.username_password_error = 'error communicating with server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.signup_error = 'Account Created'; // FIXME -- I18N+ $scope.signup = emptySignup();+ } else {+ $scope.signup_error = datum.jrData;+ }+ }+ };++ $http.+ post(`(showURL (Account Nothing) [])`, $scope.signup).+ success(callback).+ error(callback);+ };++ // changePassword()+ emptyPassword = function () {+ return { cpOldPassword: '',+ cpNewPassword: '',+ cpNewPasswordConfirm: ''+ };+ };++ $scope.password = emptyPassword();+ $scope.changePassword = function (url) {+ var u = userService.getUser();++ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.username_password_error = 'error communicating with server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.change_password_error = 'Password Changed.'; // FIXME -- I18N+ $scope.password = emptyPassword();+ } else {+ $scope.change_password_error = datum.jrData;+ }+ }+ };++ if (u.isAuthenticated) {+ $http.+ post(url, $scope.password).+ success(callback).+ error(callback);+ } else {+ $scope.change_password_error = 'Not Authenticated.'; // FIXME -- I18N+ }+ };++ // requestResetPassword()+ requestResetEmpty = function () {+ return { rrpUsername: '' };+ };+ $scope.requestReset = requestResetEmpty();+ $scope.requestResetPassword = function () {+ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.request_reset_password_msg = 'error communicating with the server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.request_reset_password_msg = datum.jrData;+ $scope.requestReset = requestResetEmpty();+ } else {+ $scope.request_reset_password_msg = datum.jrData;+ }+ }+ }++ $http.post(`(showURL PasswordRequestReset [])`, $scope.requestReset).+ success(callback).+ error(callback);+ };++ // resetPassword()+ resetEmpty = function () {+ return { rpPassword: '',+ rpPasswordConfirm: ''+ };+ };+ $scope.reset = resetEmpty();+ $scope.resetPassword = function () {+ function callback(datum, status, headers, config) {+ if (datum == null) {+ $scope.reset_password_msg = 'error communicating with the server.';+ } else {+ if (datum.jrStatus == "Ok") {+ $scope.reset_password_msg = datum.jrData;+ $scope.reset = resetEmpty();+ } else {+ $scope.reset_password_msg = datum.jrData;+ }+ }+ }++ var resetToken = $location.search().reset_token;+ if (resetToken) {+ $scope.reset.rpResetToken = resetToken;+ $http.post(`(showURL PasswordReset [])`, $scope.reset).+ success(callback).+ error(callback);+ } else {+ $scope.reset_password_msg = "reset token not found."; // FIXME -- I18N+ }+ };+ }]);+ /*+ usernamePassword.factory('authInterceptor', ['$rootScope', '$q', '$window', 'userService', function ($rootScope, $q, $window, userService) {+ return {+ request: function (config) {+ config.headers = config.headers || {};+ u = userService.getUser();+ if (u && u.token) {+ config.headers.Authorization = 'Bearer ' + u.token;+ }+ return config;+ },+ responseError: function (rejection) {+ if (rejection.status === 401) {+ // handle the case where the user is not authenticated+ userService.clearUser();+ document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;';+ }+ return $q.reject(rejection);+ }+ };+ }]);++ usernamePassword.config(['$httpProvider', function ($httpProvider) {+ $httpProvider.interceptors.push('authInterceptor');+ }]);+ */+ // upAuthenticated directive+ usernamePassword.directive('upAuthenticated', ['$rootScope', 'userService', function ($rootScope, userService) {+ return {+ restrict: 'A',+ link: function (scope, element, attrs) {+ var prevDisp = element.css('display');+ $rootScope.$watch(function () { return userService.getUser().isAuthenticated; },+ function(auth) {+ if (auth != (attrs.upAuthenticated == 'true')) {+ element.css('display', 'none');+ } else {+ element.css('display', prevDisp);+ }+ });+ }+ };+ }]);++ // upLogout directive+ usernamePassword.directive('upLogout', ['$rootScope', 'userService', function ($rootScope, userService) {+ return {+ restrict: 'E',+ replace: true,+ templateUrl: `(showURL (Partial Logout) [])`+ };+ }]);++ // upLogin directive+ usernamePassword.directive('upLogin', ['$rootScope', 'userService', function ($rootScope, userService) {+ return {+ restrict: 'E',+ replace: true,+ templateUrl: `(showURL (Partial Login) [])`+ };+ }]);++ // upLoginInline directive+ usernamePassword.directive('upLoginInline', ['$rootScope', 'userService', function ($rootScope, userService) {+ return {+ restrict: 'E',+ replace: true,+ templateUrl: `(showURL (Partial LoginInline) [])`+ };+ }]);++ // upChangePassword directive+ usernamePassword.directive('upChangePassword', ['$rootScope', '$http', '$compile', 'userService', function ($rootScope, $http, $compile, userService) {++ function link(scope, element, attrs) {+ $rootScope.$watch(function() { return userService.getUser().isAuthenticated; },+ function(auth) {+ if (auth == true) {+ $http.get(`(showURL (Partial ChangePassword) [])`).+ success(function(datum, status, headers, config) {+ element.empty();+ var newElem = angular.element(datum);+ element.append(newElem);+ $compile(newElem)(scope);+ });+ } else {+ element.empty();+ }+ });++ }++ return {+ restrict: 'E',+ link: link+ };+ }]);++ // upRequestResetPassword directive+ usernamePassword.directive('upRequestResetPassword', [function () {+ return {+ restrict: 'E',+ templateUrl: `(showURL (Partial RequestResetPasswordForm) [])`+ };+ }]);++ // upResetPassword directive+ usernamePassword.directive('upResetPassword', [function () {+ return {+ restrict: 'E',+ templateUrl: `(showURL (Partial ResetPasswordForm) [])`+ };+ }]);++ // upSignupPassword directive+ usernamePassword.directive('upSignupPassword', [function () {+ return {+ restrict: 'E',+ templateUrl: `(showURL (Partial SignupPassword) [])`+ };+ }]);+++ }+ |]+ where+ loginRedirect (Just plr) =+ [jmacro|+ // console.log(`"loginRedirect - " ++ show plr`);+ window.location.href = `plr`;+ |]+ loginRedirect Nothing =+ BlockStat []+
+ Happstack/Authenticate/Password/Core.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings, StandaloneDeriving #-}+module Happstack.Authenticate.Password.Core where++import Control.Applicative ((<$>), optional)+import Control.Monad.Trans (MonadIO(..))+import Control.Lens ((?~), (^.), (.=), (?=), assign, makeLenses, set, use, view, over)+import Control.Lens.At (at)+import qualified Crypto.PasswordStore as PasswordStore+import Crypto.PasswordStore (genSaltIO, exportSalt, makePassword)+import Data.Acid (AcidState, Query, Update, closeAcidState, makeAcidic)+import Data.Acid.Advanced (query', update')+import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom)+import qualified Data.Aeson as Aeson+import Data.Aeson (Value(..), Object(..), Result(..), decode, encode, fromJSON)+import Data.Aeson.Types (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#endif+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as B+import Data.Data (Data, Typeable)+import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, fromJust)+import Data.Monoid ((<>), mempty)+import Data.SafeCopy (SafeCopy, Migrate(..), base, extension, deriveSafeCopy)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LT+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.UserId (UserId)+import GHC.Generics (Generic)+import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod(..), AuthenticateState(..), AuthenticateConfig, usernameAcceptable, requireEmail, AuthenticateURL, CoreError(..), CreateUser(..), Email(..), unEmail, GetUserByUserId(..), GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), SimpleAddress(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, createUserCallback, email, getToken, getOrGenSharedSecret, jsonOptions, userId, username, systemFromAddress, systemReplyToAddress, systemSendmailPath, toJSONSuccess, toJSONResponse, toJSONError, tokenUser)+import Happstack.Authenticate.Password.URL (AccountURL(..))+import Happstack.Server+import HSP.JMacro+import Language.Javascript.JMacro+import Network.HTTP.Types (toQuery, renderQuery)+import Network.Mail.Mime (Address(..), Mail(..), simpleMail', renderMail', renderSendMail, renderSendMailCustom, sendmail)+import System.FilePath (combine)+import qualified Text.Email.Validate as Email+import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor)+import qualified Web.JWT as JWT+import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, intDate, secondsSinceEpoch, verify)+#if MIN_VERSION_jwt(0,8,0)+import Web.JWT (ClaimsMap(..), hmacSecret)+#else+import Web.JWT (secret)+#endif+import Web.Routes+import Web.Routes.TH++#if MIN_VERSION_jwt(0,8,0)+#else+unClaimsMap = id+#endif++------------------------------------------------------------------------------+-- PasswordConfig+------------------------------------------------------------------------------++data PasswordConfig = PasswordConfig+ { _resetLink :: Text+ , _domain :: Text+ , _passwordAcceptable :: Text -> Maybe Text+ }+ deriving (Typeable, Generic)+makeLenses ''PasswordConfig++------------------------------------------------------------------------------+-- PasswordError+------------------------------------------------------------------------------++data PasswordError+ = NotAuthenticated+ | NotAuthorized+ | InvalidUsername+ | InvalidPassword+ | InvalidUsernamePassword+ | NoEmailAddress+ | MissingResetToken+ | InvalidResetToken+ | PasswordMismatch+ | UnacceptablePassword { passwordErrorMessageMsg :: Text }+ | CoreError { passwordErrorMessageE :: CoreError }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+instance ToJSON PasswordError where toJSON = genericToJSON jsonOptions+instance FromJSON PasswordError where parseJSON = genericParseJSON jsonOptions++instance ToJExpr PasswordError where+ toJExpr = toJExpr . toJSON++mkMessageFor "HappstackAuthenticateI18N" "PasswordError" "messages/password/error" ("en")++------------------------------------------------------------------------------+-- HashedPass+------------------------------------------------------------------------------++newtype HashedPass = HashedPass { _unHashedPass :: ByteString }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''HashedPass+makeLenses ''HashedPass++-- | hash a password string+mkHashedPass :: (Functor m, MonadIO m) =>+ Text -- ^ password in plain text+ -> m HashedPass -- ^ salted and hashed+mkHashedPass pass = HashedPass <$> (liftIO $ makePassword (Text.encodeUtf8 pass) 12)++-- | verify a password+verifyHashedPass :: Text -- ^ password in plain text+ -> HashedPass -- ^ hashed version of password+ -> Bool+verifyHashedPass passwd (HashedPass hashedPass) =+ PasswordStore.verifyPassword (Text.encodeUtf8 passwd) hashedPass++------------------------------------------------------------------------------+-- PasswordState+------------------------------------------------------------------------------++data PasswordState = PasswordState+ { _passwords :: Map UserId HashedPass+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+deriveSafeCopy 1 'base ''PasswordState+makeLenses ''PasswordState++initialPasswordState :: PasswordState+initialPasswordState = PasswordState+ { _passwords = Map.empty+ }++------------------------------------------------------------------------------+-- AcidState PasswordState queries/updates+------------------------------------------------------------------------------++-- | set the password for 'UserId'+setPassword :: UserId -- ^ UserId+ -> HashedPass -- ^ the hashed password+ -> Update PasswordState ()+setPassword userId hashedPass =+ passwords . at userId ?= hashedPass++-- | delete the password for 'UserId'+deletePassword :: UserId -- ^ UserId+ -> Update PasswordState ()+deletePassword userId =+ passwords . at userId .= Nothing++-- | verify that the supplied password matches the stored hashed password for 'UserId'+verifyPasswordForUserId :: UserId -- ^ UserId+ -> Text -- ^ plain-text password+ -> Query PasswordState Bool+verifyPasswordForUserId userId plainPassword =+ do mHashed <- view (passwords . at userId)+ case mHashed of+ Nothing -> return False+ (Just hashed) -> return (verifyHashedPass plainPassword hashed)++makeAcidic ''PasswordState+ [ 'setPassword+ , 'deletePassword+ , 'verifyPasswordForUserId+ ]++------------------------------------------------------------------------------+-- Functions+------------------------------------------------------------------------------++-- | verify that the supplied username/password is valid+verifyPassword :: (MonadIO m) =>+ AcidState AuthenticateState+ -> AcidState PasswordState+ -> Username+ -> Text+ -> m Bool+verifyPassword authenticateState passwordState username password =+ do mUser <- query' authenticateState (GetUserByUsername username)+ case mUser of+ Nothing -> return False+ (Just user) ->+ query' passwordState (VerifyPasswordForUserId (view userId user) password)++------------------------------------------------------------------------------+-- API+------------------------------------------------------------------------------++data UserPass = UserPass+ { _user :: Username+ , _password :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''UserPass+instance ToJSON UserPass where toJSON = genericToJSON jsonOptions+instance FromJSON UserPass where parseJSON = genericParseJSON jsonOptions++instance ToJExpr UserPass where+ toJExpr = toJExpr . toJSON++------------------------------------------------------------------------------+-- token+------------------------------------------------------------------------------++token :: (Happstack m) =>+ AcidState AuthenticateState+ -> AuthenticateConfig+ -> AcidState PasswordState+ -> m Response+token authenticateState authenticateConfig passwordState =+ do method POST+ ~(Just (Body body)) <- takeRequestBody =<< askRq+ case Aeson.decode body of+ Nothing -> badRequest $ toJSONError (CoreError JSONDecodeFailed)+ (Just (UserPass username password)) ->+ do mUser <- query' authenticateState (GetUserByUsername username)+ case mUser of+ Nothing -> forbidden $ toJSONError InvalidPassword+ (Just u) ->+ do valid <- query' passwordState (VerifyPasswordForUserId (u ^. userId) password)+ if not valid+ then unauthorized $ toJSONError InvalidUsernamePassword+ else do token <- addTokenCookie authenticateState authenticateConfig u+#if MIN_VERSION_aeson(2,0,0)+ resp 201 $ toJSONSuccess (Object $ KM.fromList [("token", toJSON token)]) -- toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)]+#else+ resp 201 $ toJSONSuccess (Object $ HashMap.fromList [("token", toJSON token)]) -- toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)]+#endif++------------------------------------------------------------------------------+-- account+------------------------------------------------------------------------------++-- | JSON record for new account data+data NewAccountData = NewAccountData+ { _naUser :: User+ , _naPassword :: Text+ , _naPasswordConfirm :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''NewAccountData+instance ToJSON NewAccountData where toJSON = genericToJSON jsonOptions+instance FromJSON NewAccountData where parseJSON = genericParseJSON jsonOptions++-- | JSON record for change password data+data ChangePasswordData = ChangePasswordData+ { _cpOldPassword :: Text+ , _cpNewPassword :: Text+ , _cpNewPasswordConfirm :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''ChangePasswordData+instance ToJSON ChangePasswordData where toJSON = genericToJSON jsonOptions+instance FromJSON ChangePasswordData where parseJSON = genericParseJSON jsonOptions++-- | account handler+account :: (Happstack m) =>+ AcidState AuthenticateState+ -> AcidState PasswordState+ -> AuthenticateConfig+ -> PasswordConfig+ -> Maybe (UserId, AccountURL)+ -> m (Either PasswordError UserId)+-- handle new account creation via POST to \/account+-- FIXME: check that password and password confirmation match+account authenticateState passwordState authenticateConfig passwordConfig Nothing =+ do method POST+ ~(Just (Body body)) <- takeRequestBody =<< askRq+ case Aeson.decode body of+ Nothing -> badRequest (Left $ CoreError JSONDecodeFailed)+ (Just newAccount) ->+ case (authenticateConfig ^. usernameAcceptable) (newAccount ^. naUser ^. username) of+ (Just e) -> return $ Left (CoreError e)+ Nothing ->+ case validEmail (authenticateConfig ^. requireEmail) (newAccount ^. naUser ^. email) of+ (Just e) -> return $ Left e+ Nothing ->+ if (newAccount ^. naPassword /= newAccount ^. naPasswordConfirm)+ then ok $ Left PasswordMismatch+ else case (passwordConfig ^. passwordAcceptable) (newAccount ^. naPassword) of+ (Just passwdError) -> ok $ Left (UnacceptablePassword passwdError)+ Nothing -> do+ eUser <- update' authenticateState (CreateUser $ _naUser newAccount)+ case eUser of+ (Left e) -> return $ Left (CoreError e)+ (Right user) -> do+ hashed <- mkHashedPass (_naPassword newAccount)+ update' passwordState (SetPassword (user ^. userId) hashed)+ case (authenticateConfig ^. createUserCallback) of+ Nothing -> pure ()+ (Just callback) -> liftIO $ callback user+ ok $ (Right (user ^. userId))+ where+ validEmail :: Bool -> Maybe Email -> Maybe PasswordError+ validEmail required mEmail =+ case (required, mEmail) of+ (True, Nothing) -> Just $ CoreError InvalidEmail+ (False, Just (Email "")) -> Nothing+ (False, Nothing) -> Nothing+ (_, Just email) -> if Email.isValid (Text.encodeUtf8 (email ^. unEmail)) then Nothing else Just $ CoreError InvalidEmail++-- handle updates to '/account/<userId>/*'+account authenticateState passwordState authenticateConfig passwordConfig (Just (uid, url)) =+ case url of+ Password ->+ do method POST+ mUser <- getToken authenticateState+ case mUser of+ Nothing -> unauthorized (Left NotAuthenticated)+ (Just (token, _)) ->+ -- here we could have fancier policies that allow super-users to change passwords+ if ((token ^. tokenUser ^. userId) /= uid)+ then return (Left NotAuthorized)+ else do mBody <- takeRequestBody =<< askRq+ case mBody of+ Nothing -> badRequest (Left $ CoreError JSONDecodeFailed)+ ~(Just (Body body)) ->+ case Aeson.decode body of+ Nothing -> do -- liftIO $ print body+ badRequest (Left $ CoreError JSONDecodeFailed)+ (Just changePassword) ->+ do b <- verifyPassword authenticateState passwordState (token ^. tokenUser ^. username) (changePassword ^. cpOldPassword)+ if not b+ then forbidden (Left InvalidPassword)+ else if (changePassword ^. cpNewPassword /= changePassword ^. cpNewPasswordConfirm)+ then ok $ (Left PasswordMismatch)+ else case (passwordConfig ^. passwordAcceptable) (changePassword ^. cpNewPassword) of+ (Just e) -> ok (Left $ UnacceptablePassword e)+ Nothing -> do+ pw <- mkHashedPass (changePassword ^. cpNewPassword)+ update' passwordState (SetPassword uid pw)+ ok $ (Right uid)++------------------------------------------------------------------------------+-- passwordReset+------------------------------------------------------------------------------++-- | JSON record for new account data+data RequestResetPasswordData = RequestResetPasswordData+ { _rrpUsername :: Username+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''RequestResetPasswordData+instance ToJSON RequestResetPasswordData where toJSON = genericToJSON jsonOptions+instance FromJSON RequestResetPasswordData where parseJSON = genericParseJSON jsonOptions++-- | request reset password+passwordRequestReset :: (Happstack m) =>+ AuthenticateConfig+ -> PasswordConfig+ -> AcidState AuthenticateState+ -> AcidState PasswordState+ -> m (Either PasswordError Text)+passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState =+ do method POST+ ~(Just (Body body)) <- takeRequestBody =<< askRq+ case Aeson.decode body of+ Nothing -> badRequest $ Left $ CoreError JSONDecodeFailed+ (Just (RequestResetPasswordData username)) ->+ do mUser <- query' authenticateState (GetUserByUsername username)+ case mUser of+ Nothing -> notFound $ Left InvalidUsername+ (Just user) ->+ case user ^. email of+ Nothing -> return $ Left NoEmailAddress+ (Just toEm) ->+ do resetToken <- issueResetToken authenticateState user+ let resetLink' = resetTokenLink (passwordConfig ^. resetLink) resetToken+ -- liftIO $ Text.putStrLn resetLink' -- FIXME: don't print to stdout+ let from = fromMaybe (SimpleAddress Nothing (Email ("no-reply@" <> (passwordConfig ^. domain)))) (authenticateConfig ^. systemFromAddress)+ sendResetEmail (authenticateConfig ^. systemSendmailPath) toEm from (authenticateConfig ^. systemReplyToAddress) resetLink'+ return (Right "password reset request email sent.") -- FIXME: I18N++-- | generate a reset token for a UserId+resetTokenForUserId :: Text -> AcidState AuthenticateState -> AcidState PasswordState -> UserId -> IO (Either PasswordError Text)+resetTokenForUserId resetLink authenticateState passwordState userId =+ do mUser <- query' authenticateState (GetUserByUserId userId)+ case mUser of+ Nothing -> pure $ Left (CoreError InvalidUserId)+ (Just user) ->+ do resetToken <- issueResetToken authenticateState user+ pure $ Right $ resetTokenLink resetLink resetToken++-- | create a link for a reset token+resetTokenLink :: Text -- ^ base URI+ -> Text -- ^ reset token+ -> Text+resetTokenLink baseURI resetToken = baseURI <> (Text.decodeUtf8 $ renderQuery True $ toQuery [("reset_token"::Text, resetToken)])++-- | issueResetToken+issueResetToken :: (MonadIO m) =>+ AcidState AuthenticateState+ -> User+ -> m Text+issueResetToken authenticateState user =+ do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId)+ -- FIXME: add expiration time+ now <- liftIO getPOSIXTime+ let claims = JWT.JWTClaimsSet+ { JWT.iss = Nothing+ , JWT.sub = Nothing+ , JWT.aud = Nothing+ , JWT.exp = intDate $ now + 60+ , JWT.nbf = Nothing+ , JWT.iat = Nothing+ , JWT.jti = Nothing+ , JWT.unregisteredClaims =+#if MIN_VERSION_jwt(0,8,0)+ JWT.ClaimsMap $+#endif+ Map.singleton "reset-password" (toJSON user)+ }+#if MIN_VERSION_jwt(0,10,0)+ return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims+#elif MIN_VERSION_jwt(0,9,0)+ return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims+#else+ return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims+#endif++-- FIXME: I18N+-- FIXME: call renderSendMail+sendResetEmail :: (MonadIO m) =>+ Maybe FilePath+ -> Email+ -> SimpleAddress+ -> Maybe SimpleAddress+ -> Text+ -> m ()+sendResetEmail mSendmailPath (Email toEm) (SimpleAddress fromNm (Email fromEm)) mReplyTo resetLink = liftIO $+ do let mail = addReplyTo mReplyTo $ simpleMail' (Address Nothing toEm) (Address fromNm fromEm) "Reset Password Request" (LT.fromStrict resetLink)+ case mSendmailPath of+ Nothing -> renderSendMail mail+ (Just sendmailPath) -> renderSendMailCustom sendmailPath ["-t"] mail+ where+ addReplyTo :: Maybe SimpleAddress -> Mail -> Mail+ addReplyTo Nothing m = m+ addReplyTo (Just (SimpleAddress rplyToNm rplyToEm)) m =+ let m' = m { mailHeaders = (mailHeaders m) } in m'++-- | JSON record for new account data+data ResetPasswordData = ResetPasswordData+ { _rpPassword :: Text+ , _rpPasswordConfirm :: Text+ , _rpResetToken :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)+makeLenses ''ResetPasswordData+instance ToJSON ResetPasswordData where toJSON = genericToJSON jsonOptions+instance FromJSON ResetPasswordData where parseJSON = genericParseJSON jsonOptions++passwordReset :: (Happstack m) =>+ AcidState AuthenticateState+ -> AcidState PasswordState+ -> PasswordConfig+ -> m (Either PasswordError Text)+passwordReset authenticateState passwordState passwordConfig =+ do method POST+ ~(Just (Body body)) <- takeRequestBody =<< askRq+ case Aeson.decode body of+ Nothing -> badRequest $ Left $ CoreError JSONDecodeFailed+ (Just (ResetPasswordData password passwordConfirm resetToken)) ->+ do mUser <- decodeAndVerifyResetToken authenticateState resetToken+ case mUser of+ Nothing -> return (Left InvalidResetToken)+ (Just (user, _)) ->+ if password /= passwordConfirm+ then return (Left PasswordMismatch)+ else case (passwordConfig ^. passwordAcceptable) password of+ (Just e) -> ok $ Left $ UnacceptablePassword e+ Nothing -> do pw <- mkHashedPass password+ update' passwordState (SetPassword (user ^. userId) pw)+ ok $ Right "Password Reset." -- I18N+ {-+ do mTokenTxt <- optional $ queryString $ lookText' "reset_btoken"+ case mTokenTxt of+ Nothing -> badRequest $ Left MissingResetToken+ (Just tokenTxt) ->+ do mUser <- decodeAndVerifyResetToken authenticateState tokenTxt+ case mUser of+ Nothing -> return (Left InvalidResetToken)+ (Just (user, _)) ->+ if password /= passwordConfirm+ then return (Left PasswordMismatch)+ else do pw <- mkHashedPass password+ update' passwordState (SetPassword (user ^. userId) pw)+ ok $ Right ()+-- ok $ Right $ Text.pack $ show (password, passwordConfirm)+-}++ {-+ do mToken <- optional <$> queryString $ lookText "token"+ case mToken of+ Nothing -> return (Left MissingResetToken)+ (Just token) ->+ do method GET+-}++decodeAndVerifyResetToken :: (MonadIO m) =>+ AcidState AuthenticateState+ -> Text+ -> m (Maybe (User, JWT VerifiedJWT))+decodeAndVerifyResetToken authenticateState token =+ do let mUnverified = JWT.decode token+ case mUnverified of+ Nothing -> return Nothing+ (Just unverified) ->+ case Map.lookup "reset-password" (unClaimsMap (unregisteredClaims (claims unverified))) of+ Nothing -> return Nothing+ (Just uv) ->+ case fromJSON uv of+ (Error _) -> return Nothing+ (Success u) ->+ do mssecret <- query' authenticateState (GetSharedSecret (u ^. userId))+ case mssecret of+ Nothing -> return Nothing+ (Just ssecret) ->+#if MIN_VERSION_jwt(0,11,0)+ case verify (JWT.toVerify $ hmacSecret (_unSharedSecret ssecret)) unverified of+#elif MIN_VERSION_jwt(0,8,0)+ case verify (hmacSecret (_unSharedSecret ssecret)) unverified of+#else+ case verify (secret (_unSharedSecret ssecret)) unverified of+#endif+ Nothing -> return Nothing+ (Just verified) ->+ do now <- liftIO getPOSIXTime+ case JWT.exp (claims verified) of+ Nothing -> return Nothing+ (Just exp') ->+ if (now > secondsSinceEpoch exp')+ then return Nothing+ else return (Just (u, verified))
+ Happstack/Authenticate/Password/Partials.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-}+module Happstack.Authenticate.Password.Partials where++import Control.Category ((.), id)+import Control.Lens ((^.))+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans (MonadIO, lift)+import Data.Acid (AcidState)+import Data.Data (Data, Typeable)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.UserId (UserId)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LT+import HSP+import Happstack.Server.HSP.HTML ()+import Language.Haskell.HSX.QQ (hsx)+import Language.Javascript.JMacro+import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken, tokenUser, userId)+import Happstack.Authenticate.Password.Core (PasswordError(NotAuthenticated))+import Happstack.Authenticate.Password.URL (AccountURL(..), PasswordURL(..), nestPasswordURL)+import Happstack.Authenticate.Password.PartialsURL (PartialURL(..))+import Happstack.Server (Happstack, unauthorized)+import Happstack.Server.XMLGenT ()+import HSP.JMacro ()+import Prelude hiding ((.), id)+import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage)+import Web.Routes+import Web.Routes.XMLGenT ()+import Web.Routes.TH (derivePathInfo)++type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m))+type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m))++data PartialMsgs+ = UsernameMsg+ | EmailMsg+ | PasswordMsg+ | PasswordConfirmationMsg+ | SignUpMsg+ | SignInMsg+ | LogoutMsg+ | OldPasswordMsg+ | NewPasswordMsg+ | NewPasswordConfirmationMsg+ | ChangePasswordMsg+ | RequestPasswordResetMsg++mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/password/partials" "en"++instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where+ asChild msg =+ do lang <- ask+ asChild $ renderMessage HappstackAuthenticateI18N lang msg++instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where+ asAttr (k := v) =+ do lang <- ask+ asAttr (k := renderMessage HappstackAuthenticateI18N lang v)++routePartial :: (Functor m, Monad m, Happstack m) =>+ AcidState AuthenticateState+ -> PartialURL+ -> Partial m XML+routePartial authenticateState url =+ case url of+ LoginInline -> usernamePasswordForm True+ Login -> usernamePasswordForm False+ Logout -> logoutForm+ SignupPassword -> signupPasswordForm+ ChangePassword ->+ do mUser <- getToken authenticateState+ case mUser of+ Nothing -> unauthorized =<< [hsx| <p><% show NotAuthenticated %></p> |] -- FIXME: I18N+ (Just (token, _)) -> changePasswordForm (token ^. tokenUser ^. userId)+ RequestResetPasswordForm -> requestResetPasswordForm+ ResetPasswordForm -> resetPasswordForm++signupPasswordForm :: (Functor m, Monad m) =>+ Partial m XML+signupPasswordForm =+ [hsx|+ <form ng-submit="signupPassword()" role="form">+ <div>{{signup_error}}</div>+ <div class="form-group">+ <label class="sr-only" for="su-username"><% UsernameMsg %></label>+ <input class="form-control" ng-model="signup.naUser.username" type="text" id="username" name="su-username" value="" placeholder=UsernameMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="su-email"><% EmailMsg %></label>+ <input class="form-control" ng-model="signup.naUser.email" type="email" id="su-email" name="email" value="" placeholder=EmailMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="su-password"><% PasswordMsg %></label>+ <input class="form-control" ng-model="signup.naPassword" type="password" id="su-password" name="su-pass" value="" placeholder=PasswordMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="su-password-confirm"><% PasswordConfirmationMsg %></label>+ <input class="form-control" ng-model="signup.naPasswordConfirm" type="password" id="su-password-confirm" name="su-pass-confirm" value="" placeholder=PasswordConfirmationMsg />+ </div>+ <div class="form-group">+ <input class="form-control" type="submit" value=SignUpMsg />+ </div>+ </form>+ |]++usernamePasswordForm :: (Functor m, Monad m) =>+ Bool+ -> Partial m XML+usernamePasswordForm inline = [hsx|+ <span>+ <span ng-show="!isAuthenticated">+ <form ng-submit="login()" role="form" (if inline then ["class" := "navbar-form navbar-left"] :: [Attr Text Text] else [])>+ <div class="form-group">{{username_password_error}}</div>+ <div class="form-group">+ <label class="sr-only" for="username"><% UsernameMsg %> </label>+ <input class="form-control" ng-model="user.user" type="text" id="username" name="user" placeholder=UsernameMsg />+ </div><% " " :: Text %>+ <div class="form-group">+ <label class="sr-only" for="password"><% PasswordMsg %></label>+ <input class="form-control" ng-model="user.password" type="password" id="password" name="pass" placeholder=PasswordMsg />+ </div><% " " :: Text %>+ <div class="form-group">+ <input class="form-control" type="submit" value=SignInMsg />+ </div>+ </form>+ </span>+ </span>+ |]++logoutForm :: (Functor m, MonadIO m) => Partial m XML+logoutForm = [hsx|+ <span ng-show="isAuthenticated">+ <div class="form-group">+ <a ng-click="logout()" href="#"><% LogoutMsg %></a>+ </div>+ </span>+ |]++changePasswordForm :: (Functor m, MonadIO m) =>+ UserId+ -> Partial m XML+changePasswordForm userId =+ do url <- lift $ nestPasswordURL $ showURL (Account (Just (userId, Password)))+ let changePasswordFn = "changePassword('" <> url <> "')"+ [hsx|+ <form ng-submit=changePasswordFn role="form">+ <div class="form-group">{{change_password_error}}</div>+ <div class="form-group">+ <label class="sr-only" for="password"><% OldPasswordMsg %></label>+ <input class="form-control" ng-model="password.cpOldPassword" type="password" id="old-password" name="old-pass" placeholder=OldPasswordMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="password"><% NewPasswordMsg %></label>+ <input class="form-control" ng-model="password.cpNewPassword" type="password" id="new-password" name="new-pass" placeholder=NewPasswordMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="password"><% NewPasswordConfirmationMsg %></label>+ <input class="form-control" ng-model="password.cpNewPasswordConfirm" type="password" id="new-password-confirm" name="new-pass-confirm" placeholder=NewPasswordConfirmationMsg />+ </div>+ <div class="form-group">+ <input class="form-control" type="submit" value=ChangePasswordMsg />+ </div>+ </form>++ |]++requestResetPasswordForm :: (Functor m, MonadIO m) =>+ Partial m XML+requestResetPasswordForm =+ do -- url <- lift $ nestPasswordURL $ showURL PasswordReset+ -- let changePasswordFn = "resetPassword('" <> url <> "')"+ [hsx|+ <div>+ <form ng-submit="requestResetPassword()" role="form">+ <div class="form-group">{{request_reset_password_msg}}</div>+ <div class="form-group">+ <label class="sr-only" for="reset-username"><% UsernameMsg %></label>+ <input class="form-control" ng-model="requestReset.rrpUsername" type="text" id="reset-username" name="username" placeholder=UsernameMsg />+ </div>+ <div class="form-group">+ <input class="form-control" type="submit" value=RequestPasswordResetMsg />+ </div>+ </form>+ </div>+ |]++resetPasswordForm :: (Functor m, MonadIO m) =>+ Partial m XML+resetPasswordForm =+ [hsx|+ <div>+ <form ng-submit="resetPassword()" role="form">+ <div class="form-group">{{reset_password_msg}}</div>+ <div class="form-group">+ <label class="sr-only" for="reset-password"><% PasswordMsg %></label>+ <input class="form-control" ng-model="reset.rpPassword" type="password" id="reset-password" name="reset-password" placeholder=PasswordMsg />+ </div>+ <div class="form-group">+ <label class="sr-only" for="reset-password-confirm"><% PasswordConfirmationMsg %></label>+ <input class="form-control" ng-model="reset.rpPasswordConfirm" type="password" id="reset-password-confirm" name="reset-password-confirm" placeholder=PasswordConfirmationMsg />+ </div>+ <div class="form-group">+ <input class="form-control" type="submit" value=ChangePasswordMsg />+ </div>+ </form>+ </div>+ |]
+ Happstack/Authenticate/Password/PartialsURL.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeOperators, OverloadedStrings #-}+module Happstack.Authenticate.Password.PartialsURL where++import Data.Data (Data, Typeable)+import Control.Category ((.), id)+import GHC.Generics (Generic)+import Prelude hiding ((.), id)+import Text.Boomerang.TH (makeBoomerangs)+import Web.Routes (PathInfo(..))+import Web.Routes.Boomerang (Router, (:-), (<>), boomerangFromPathSegments, boomerangToPathSegments)+++data PartialURL+ = LoginInline+ | Login+ | Logout+ | SignupPassword+ | ChangePassword+ | RequestResetPasswordForm+ | ResetPasswordForm+ deriving (Eq, Ord, Data, Typeable, Generic)++makeBoomerangs ''PartialURL++partialURL :: Router () (PartialURL :- ())+partialURL =+ ( "login-inline" . rLoginInline+ <> "login" . rLogin+ <> "logout" . rLogout+ <> "signup-password" . rSignupPassword+ <> "change-password" . rChangePassword+ <> "reset-password-form" . rResetPasswordForm+ <> "request-reset-password-form" . rRequestResetPasswordForm+ )++instance PathInfo PartialURL where+ fromPathSegments = boomerangFromPathSegments partialURL+ toPathSegments = boomerangToPathSegments partialURL
+ Happstack/Authenticate/Password/Route.hs view
@@ -0,0 +1,82 @@+module Happstack.Authenticate.Password.Route where++import Control.Applicative ((<$>))+import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Monad.Trans (MonadIO(liftIO))+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar)+import Data.Acid (AcidState, closeAcidState, makeAcidic)+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.Password.Core (PasswordConfig(..), PasswordError(..), PasswordState, account, initialPasswordState, passwordReset, passwordRequestReset, token)+import Happstack.Authenticate.Password.Controllers (usernamePasswordCtrl)+import Happstack.Authenticate.Password.URL (PasswordURL(..), passwordAuthenticationMethod)+import Happstack.Authenticate.Password.Partials (routePartial)+import Happstack.Server (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse)+import Happstack.Server.JMacro ()+import HSP (unXMLGenT)+import HSP.HTML4 (html4StrictFrag)+import Language.Javascript.JMacro (JStat)+import System.FilePath (combine)+import Text.Shakespeare.I18N (Lang)+import Web.Routes (PathInfo(..), RouteT(..), mapRouteT, parseSegments)++------------------------------------------------------------------------------+-- routePassword+------------------------------------------------------------------------------++routePassword :: (Happstack m) =>+ TVar PasswordConfig+ -> AcidState AuthenticateState+ -> TVar AuthenticateConfig+ -> AcidState PasswordState+ -> [Text]+ -> RouteT AuthenticateURL (ReaderT [Lang] m) Response+routePassword passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments =+ case parseSegments fromPathSegments pathSegments of+ (Left _) -> notFound $ toJSONError URLDecodeFailed+ (Right url) ->+ do authenticateConfig <- liftIO $ atomically $ readTVar authenticateConfigTV+ passwordConfig <- liftIO $ atomically $ readTVar passwordConfigTV+ case url of+ Token -> token authenticateState authenticateConfig passwordState+ Account mUrl -> toJSONResponse <$> account authenticateState passwordState authenticateConfig passwordConfig mUrl+ (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u)+ return $ toResponse (html4StrictFrag, xml)+ PasswordRequestReset -> toJSONResponse <$> passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState+ PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig+ UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl authenticateConfigTV++------------------------------------------------------------------------------+-- initPassword+------------------------------------------------------------------------------++initPassword :: PasswordConfig+ -> FilePath+ -> AcidState AuthenticateState+ -> TVar AuthenticateConfig+ -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)+initPassword passwordConfig basePath authenticateState authenticateConfigTV =+ do passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState+ passwordConfigTV <- atomically $ newTVar passwordConfig+ initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV++initPassword' :: TVar PasswordConfig+ -> AcidState PasswordState+ -> FilePath+ -> AcidState AuthenticateState+ -> TVar AuthenticateConfig+ -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)+initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV =+ do let shutdown = \normal ->+ if normal+ then createCheckpointAndClose passwordState+ else closeAcidState passwordState+ authenticationHandler pathSegments =+ do langsOveride <- queryString $ lookTexts' "_LANG"+ langs <- bestLanguage <$> acceptLanguage+ mapRouteT (flip runReaderT (langsOveride ++ langs)) $+ routePassword passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments+ pure (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl authenticateConfigTV)
+ Happstack/Authenticate/Password/URL.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators, OverloadedStrings #-}+module Happstack.Authenticate.Password.URL where++import Control.Category ((.), id)+import Data.Data (Data, Typeable)+import Data.UserId (UserId(..), rUserId)+import GHC.Generics (Generic)+import Prelude hiding ((.), id)+import Web.Routes (RouteT(..))+import Web.Routes.TH (derivePathInfo)+import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), nestAuthenticationMethod)+import Happstack.Authenticate.Password.PartialsURL (PartialURL(..), partialURL)+import Text.Boomerang.TH (makeBoomerangs)+import Web.Routes (PathInfo(..))+import Web.Routes.Boomerang+++------------------------------------------------------------------------------+-- passwordAuthenticationMethod+------------------------------------------------------------------------------++passwordAuthenticationMethod :: AuthenticationMethod+passwordAuthenticationMethod = AuthenticationMethod "password"++------------------------------------------------------------------------------+-- AccountURL+------------------------------------------------------------------------------++data AccountURL+ = Password+ deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)++makeBoomerangs ''AccountURL++accountURL :: Router () (AccountURL :- ())+accountURL =+ ( rPassword . "password"+ )++instance PathInfo AccountURL where+ fromPathSegments = boomerangFromPathSegments accountURL+ toPathSegments = boomerangToPathSegments accountURL++------------------------------------------------------------------------------+-- PasswordURL+------------------------------------------------------------------------------++data PasswordURL+ = Token+ | Account (Maybe (UserId, AccountURL))+ | Partial PartialURL+ | PasswordRequestReset+ | PasswordReset+ | UsernamePasswordCtrl+ deriving (Eq, Ord, Data, Typeable, Generic)++makeBoomerangs ''PasswordURL++passwordURL :: Router () (PasswordURL :- ())+passwordURL =+ ( "token" . rToken+ <> "account" </> rAccount . rMaybe (rPair . (rUserId . integer) </> accountURL)+ <> "partial" </> rPartial . partialURL+ <> "password-request-reset" . rPasswordRequestReset+ <> "password-reset" . rPasswordReset+ <> "js" </> rUsernamePasswordCtrl+ )++instance PathInfo PasswordURL where+ fromPathSegments = boomerangFromPathSegments passwordURL+ toPathSegments = boomerangToPathSegments passwordURL++-- showPasswordURL :: (MonadRoute m) => PasswordURL -> m Text+nestPasswordURL :: RouteT PasswordURL m a -> RouteT AuthenticateURL m a+nestPasswordURL =+ nestAuthenticationMethod passwordAuthenticationMethod+
+ Happstack/Authenticate/Route.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+module Happstack.Authenticate.Route where++import Control.Applicative ((<$>))+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, newTVar)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Acid (AcidState)+import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose)+import qualified Data.Map as Map (fromList, lookup)+import Data.Maybe (fromMaybe, Maybe(..))+import Data.Monoid (mconcat)+import Data.Traversable (sequence)+import Data.Unique (hashUnique, newUnique)+import Data.UserId (UserId)+import HSP.JMacro (IntegerSupply(..))+import Happstack.Authenticate.Controller (authenticateCtrl)+import Happstack.Authenticate.Core (AuthenticateConfig, AuthenticateState, AuthenticateURL(..), AuthenticationHandler, AuthenticationHandlers, AuthenticationMethod, CoreError(HandlerNotFound), initialAuthenticateState, toJSONError)+import Happstack.Server (notFound, ok, Response, ServerPartT, ToMessage(toResponse))+import Happstack.Server.JMacro ()+import Language.Javascript.JMacro (JStat)+import Prelude (($), (.), Bool(True), FilePath, fromIntegral, Functor(..), Integral(mod), IO, map, mapM, Monad(return), sequence_, unzip3)+import Prelude hiding (sequence)+import System.FilePath (combine)+import Web.Routes (RouteT)++------------------------------------------------------------------------------+-- route+------------------------------------------------------------------------------++route :: [RouteT AuthenticateURL (ServerPartT IO) JStat]+ -> AuthenticationHandlers+ -> AuthenticateURL+ -> RouteT AuthenticateURL (ServerPartT IO) Response+route controllers authenticationHandlers url =+ do case url of+ (AuthenticationMethods (Just (authenticationMethod, pathInfo))) ->+ case Map.lookup authenticationMethod authenticationHandlers of+ (Just handler) -> handler pathInfo+ Nothing -> notFound $ toJSONError (HandlerNotFound {- authenticationMethod-} ) --FIXME+ Controllers ->+ do js <- sequence (authenticateCtrl:controllers)+ ok $ toResponse (mconcat js)++------------------------------------------------------------------------------+-- initAuthenticate+------------------------------------------------------------------------------++initAuthentication+ :: Maybe FilePath+ -> AuthenticateConfig+ -> [FilePath -> AcidState AuthenticateState -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)]+ -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState, TVar AuthenticateConfig)+initAuthentication mBasePath authenticateConfig initMethods =+ do let authenticatePath = combine (fromMaybe "state" mBasePath) "authenticate"+ authenticateState <- openLocalStateFrom (combine authenticatePath "core") initialAuthenticateState+ authenticateConfigTV <- atomically $ newTVar authenticateConfig+ -- FIXME: need to deal with one of the initMethods throwing an exception+ (cleanupPartial, handlers, javascript) <- unzip3 <$> mapM (\initMethod -> initMethod authenticatePath authenticateState authenticateConfigTV) initMethods+ let cleanup = sequence_ $ createCheckpointAndClose authenticateState : (map (\c -> c True) cleanupPartial)+ h = route javascript (Map.fromList handlers)+ return (cleanup, h, authenticateState, authenticateConfigTV)++instance (Functor m, MonadIO m) => IntegerSupply (RouteT AuthenticateURL m) where+ nextInteger =+ fmap (fromIntegral . (`mod` 1024) . hashUnique) (liftIO newUnique)
happstack-authenticate.cabal view
@@ -1,5 +1,5 @@ Name: happstack-authenticate-Version: 0.10.15+Version: 2.6.1 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/@@ -7,50 +7,77 @@ License-file: LICENSE Author: Jeremy Shaw. Maintainer: jeremy@seereason.com-Copyright: 2011 SeeReason Partners, LLC+Copyright: 2011-2015 SeeReason Partners, LLC Category: Web Build-type: Simple-Cabal-version: >=1.6-+Cabal-version: >=1.10+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2+data-files:+ messages/core/en.msg+ messages/openid/error/en.msg+ messages/openid/partials/en.msg+ messages/password/error/en.msg+ messages/password/partials/en.msg source-repository head- type: darcs- subdir: happstack-authenticate- location: http://hub.darcs.net/stepcut/happstack-+ type: git+ location: https://github.com/Happstack/happstack-authenticate.git 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+ Default-language: Haskell2010+ Exposed-modules: Happstack.Authenticate.Core+ Happstack.Authenticate.Controller+ Happstack.Authenticate.Route+ Happstack.Authenticate.Password.Controllers+ Happstack.Authenticate.Password.Core+ Happstack.Authenticate.Password.Partials+ Happstack.Authenticate.Password.PartialsURL+ Happstack.Authenticate.Password.Route+ Happstack.Authenticate.Password.URL+ Happstack.Authenticate.OpenId.Controllers+ Happstack.Authenticate.OpenId.Core+ Happstack.Authenticate.OpenId.Partials+ Happstack.Authenticate.OpenId.PartialsURL+ Happstack.Authenticate.OpenId.Route+ Happstack.Authenticate.OpenId.URL - Build-depends: base > 4 && < 5,- acid-state >= 0.6 && <= 0.13,- aeson >= 0.4 && < 0.9,++ Build-depends: base > 4 && < 5,+ acid-state >= 0.6 && < 0.17,+ aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.6) || (>= 2.0 && < 2.1), authenticate == 1.3.*,- blaze-html >= 0.5 && < 0.8,- bytestring >= 0.9 && < 0.11,- containers >= 0.4 && < 0.6,- ixset >= 1.0 && < 1.1,- happstack-server >= 6.0 && < 7.4,- http-conduit >= 1.4 && < 2.2,- http-types >= 0.6 && < 0.9,- fb >= 0.13 && < 1.1,- safecopy >= 0.6,- mtl >= 2.0,+ base64-bytestring >= 1.0 && < 1.3,+ boomerang >= 1.4 && < 1.5,+ bytestring >= 0.9 && < 0.12,+ containers >= 0.4 && < 0.7,+ data-default >= 0.5 && < 0.8,+ email-validate >= 2.1 && < 2.4,+ filepath >= 1.3 && < 1.5,+ hsx2hs >= 0.13 && < 0.15,+ jmacro >= 0.6.11 && < 0.7,+ jwt >= 0.3 && < 0.12,+ ixset-typed >= 0.3 && < 0.6,+ happstack-jmacro >= 7.0 && < 7.1,+ happstack-server >= 6.0 && < 7.8,+ happstack-hsp >= 7.3 && < 7.4,+ http-conduit >= 2.1.0 && < 2.4,+ http-types >= 0.6 && < 0.13,+ hsp >= 0.10 && < 0.11,+ hsx-jmacro >= 7.3 && < 7.4,+ safecopy >= 0.8 && < 0.11,+ mime-mail >= 0.4 && < 0.6,+ mtl >= 2.0 && < 2.3,+ lens >= 4.2 && < 5.2, pwstore-purehaskell == 2.1.*,- QuickCheck >= 2,- text >= 0.11 && < 1.3,- time >= 1.2 && < 1.6,- reform == 0.2.*,- reform-blaze == 0.2.*,- reform-happstack == 0.2.*,+ stm >= 2.4 && < 2.6,+ text >= 0.11 && < 2.1,+ time >= 1.2 && < 1.14,+ userid >= 0.1 && < 0.2,+ random >= 1.0 && < 1.3,+ shakespeare >= 2.0 && < 2.1, unordered-containers == 0.2.*, web-routes >= 0.26 && < 0.28,- web-routes-happstack == 0.23.*+ web-routes-boomerang >= 0.28 && < 0.29,+ web-routes-happstack == 0.23.*,+ web-routes-th >= 0.22 && < 0.23,+ web-routes-hsp >= 0.24 && < 0.25
+ messages/core/en.msg view
@@ -0,0 +1,12 @@+HandlerNotFound: Handler Not Found.+URLDecodeFailed: Failed to decode URL.+UsernameAlreadyExists: Username already exists.+AuthorizationRequired: Authorization required.+Forbidden: Forbidden.+JSONDecodeFailed: Failed to decode JSON data.+InvalidUserId: Invalid UserId+UsernameNotAcceptable: Username not acceptable.+InvalidEmail: Invalid email address.+++
+ messages/openid/error/en.msg view
@@ -0,0 +1,3 @@+UnknownIdentifier: OpenId identifier is not associated with any account on this system.+CoreError e@CoreError: #{renderMessage HappstackAuthenticateI18N ["en"] e}+
+ messages/openid/partials/en.msg view
@@ -0,0 +1,4 @@+UsingYahooMsg: Yahoo OpenId+SetRealmMsg: Update OpenId Realm+OpenIdRealmMsg: OpenId Realm+
+ messages/password/error/en.msg view
@@ -0,0 +1,11 @@+NotAuthenticated: Not Authenticated+NotAuthorized: Not Authorized+InvalidUsername: Invalid Username+InvalidPassword: Invalid Password+InvalidUsernamePassword: Invalid username or password+NoEmailAddress: No email address found+MissingResetToken: Missing reset token+InvalidResetToken: Invalid reset token+PasswordMismatch: Passwords do not match+UnacceptablePassword msg@Text: Unacceptable Password. #{msg}+CoreError e@CoreError: #{renderMessage HappstackAuthenticateI18N ["en"] e}
+ messages/password/partials/en.msg view
@@ -0,0 +1,12 @@+UsernameMsg: username+EmailMsg: email+PasswordMsg: password+PasswordConfirmationMsg: password confirmation+SignUpMsg: sign up+SignInMsg: sign in+LogoutMsg: logout+OldPasswordMsg: old password+NewPasswordMsg: new password+NewPasswordConfirmationMsg: new password confirmation+ChangePasswordMsg: change password+RequestPasswordResetMsg: request password reset