diff --git a/Happstack/Auth.hs b/Happstack/Auth.hs deleted file mode 100644 --- a/Happstack/Auth.hs +++ /dev/null @@ -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) diff --git a/Happstack/Auth/Blaze/Templates.hs b/Happstack/Auth/Blaze/Templates.hs deleted file mode 100644 --- a/Happstack/Auth/Blaze/Templates.hs +++ /dev/null @@ -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 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>]) --} diff --git a/Happstack/Auth/Core/Auth.hs b/Happstack/Auth/Core/Auth.hs deleted file mode 100644 --- a/Happstack/Auth/Core/Auth.hs +++ /dev/null @@ -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) diff --git a/Happstack/Auth/Core/AuthParts.hs b/Happstack/Auth/Core/AuthParts.hs deleted file mode 100644 --- a/Happstack/Auth/Core/AuthParts.hs +++ /dev/null @@ -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 ()) - diff --git a/Happstack/Auth/Core/AuthProfileURL.hs b/Happstack/Auth/Core/AuthProfileURL.hs deleted file mode 100644 --- a/Happstack/Auth/Core/AuthProfileURL.hs +++ /dev/null @@ -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 - ] diff --git a/Happstack/Auth/Core/AuthURL.hs b/Happstack/Auth/Core/AuthURL.hs deleted file mode 100644 --- a/Happstack/Auth/Core/AuthURL.hs +++ /dev/null @@ -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) diff --git a/Happstack/Auth/Core/Profile.hs b/Happstack/Auth/Core/Profile.hs deleted file mode 100644 --- a/Happstack/Auth/Core/Profile.hs +++ /dev/null @@ -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) - - - diff --git a/Happstack/Auth/Core/ProfileParts.hs b/Happstack/Auth/Core/ProfileParts.hs deleted file mode 100644 --- a/Happstack/Auth/Core/ProfileParts.hs +++ /dev/null @@ -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) diff --git a/Happstack/Auth/Core/ProfileURL.hs b/Happstack/Auth/Core/ProfileURL.hs deleted file mode 100644 --- a/Happstack/Auth/Core/ProfileURL.hs +++ /dev/null @@ -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) --} diff --git a/Happstack/Authenticate/Controller.hs b/Happstack/Authenticate/Controller.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Controller.hs @@ -0,0 +1,108 @@ +{-# 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;'; + }; + + }]); + + // 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() { + return(this.userCache); + }, + + clearUser: function () { +// alert('clearUser'); + this.setUser({ isAuthenticated: false, + claims: {}, + token: null + }); + } + }; + + service.userCacheInit(); + + return service; + }]); + } + |] + diff --git a/Happstack/Authenticate/Core.hs b/Happstack/Authenticate/Core.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Core.hs @@ -0,0 +1,678 @@ +{-# LANGUAGE 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 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) +import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +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 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 Language.Javascript.JMacro +import Prelude hiding ((.), id) +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, secret, verify) +import Web.Routes (RouteT, PathInfo(..), nestURL) +import Web.Routes.Boomerang +import Web.Routes.Happstack () +import Web.Routes.TH (derivePathInfo) + +data HappstackAuthenticateI18N = HappstackAuthenticateI18N + +-- | 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 } + +-- | 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 a) + +-- | convert an error to a JSON encoded 'Response' +toJSONError :: forall e. (RenderMessage HappstackAuthenticateI18N e) => e -> Response +toJSONError e = toResponseBS "application/json" (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) + +------------------------------------------------------------------------------ +-- 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 + +------------------------------------------------------------------------------ +-- 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 + 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") + +------------------------------------------------------------------------------ +-- 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 + +-- | look up a 'User' by their 'Email' +getUserByEmail :: Email + -> Query AuthenticateState (Maybe User) +getUserByEmail email = + do us <- view users + return $ getOne $ 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 + , 'getUserByEmail + , '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 + -> (UserId -> IO Bool) -- ^ isAuthAdmin function + -> User -- ^ the user + -> m TokenText +issueToken authenticateState isAuthAdmin user = + do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) + admin <- liftIO $ isAuthAdmin (user ^. userId) + let claims = def { unregisteredClaims = + Map.fromList [ ("user" , toJSON user) + , ("authAdmin", toJSON admin) + ] } + return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims + +-- | decode and verify the `TokenText`. If successful, return the +-- `Token` otherwise `Nothing`. +decodeAndVerifyToken :: (MonadIO m) => + AcidState AuthenticateState + -> TokenText + -> m (Maybe (Token, JWT VerifiedJWT)) +decodeAndVerifyToken authenticateState 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" (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 + case verify (secret (_unSharedSecret ssecret)) unverified of + Nothing -> return Nothing + (Just verified) -> + case Map.lookup "authAdmin" (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 + -> (UserId -> IO Bool) + -> User + -> m TokenText +addTokenCookie authenticateState isAuthAdmin user = + do token <- issueToken authenticateState isAuthAdmin 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 }) + 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) -> decodeAndVerifyToken authenticateState (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' + decodeAndVerifyToken authenticateState (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) diff --git a/Happstack/Authenticate/OpenId/Controllers.hs b/Happstack/Authenticate/OpenId/Controllers.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/Controllers.hs @@ -0,0 +1,360 @@ +{-# 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(UsingGoogle, 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.isAuthenticated = userService.getUser().isAuthenticated; + +// $scope.$watch(function () { return userService.getUser().isAuthenticated; }, function(newVal, oldVal) { $scope.isAuthenticated = newVal; }); + + $scope.openIdWindow = function (providerUrl) { +// openIdWindow = window.open(`(showURL ReturnTo [])`, "_blank", "toolbar=0"); + 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) { + $http.post(setRealmUrl, $scope.openIdRealm). + success(function(datum, status, headers,config) { + $scope.set_openid_realm_msg = 'Realm Updated.'; // FIXME -- I18N + }). + error(function (datum, status, headers, config) { + $scope.set_openid_realm_msg = datum.error; + })}; + }]); + + openId.directive('openidGoogle', ['$rootScope', function ($rootScope) { + return { + restrict: 'E', + replace: true, + templateUrl: `(showURL (Partial UsingGoogle) [])` + }; + }]); + + 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) [])` + }; + }]); + + |] + +{- +openIdCtrlJs 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 + } + + var happstackAuthentication = angular.module('happstackAuthentication', []); + happstackAuthentication.factory('userService', ['$rootScope', function ($rootScope) { + var defaultUser = { isAuthenticated: false, + username: '<unset>', + token: null + }; + + var service = { + userCache: defaultUser, + setUser: function(u) { +// alert('setUser:' + JSON.stringify(u)); + userCache = u; + localStorage.setItem('user', JSON.stringify(u)); + }, + + getUser: function() { + var item = localStorage.getItem('user'); + if (item) { +// alert('getUser: ' + item); + var user = JSON.parse(item); + return(user); + } + }, + + clearUser: function () { + userCache = defaultUser; + this.setUser(defaultUser); + } + }; + + if (!localStorage.getItem('user')) { + service.clearUser(); + } + + return service; + }]); + + var openId = angular.module('openId', ['happstackAuthentication']); + + openId.controller('UsernamePasswordCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService) { + $scope.isAuthenticated = userService.getUser().isAuthenticated; + + $scope.login = function () { + $http. + post(`(showURL Token [])`, $scope.user). + success(function (datum, status, headers, config) { + var encodedClaims = datum.token.split('.')[1]; + var claims = JSON.parse(url_base64_decode(encodedClaims)); + $scope.username_password_error = ''; + + var u = userService.getUser(); + u.isAuthenticated = true; + $scope.isAuthenticated = true; + u.username = $scope.user.user; // FIXME: this should come from the token + u.token = datum.token; + userService.setUser(u); + }). + error(function (datum, status, headers, config) { + // Erase the token if the user fails to log in + userService.clearUser(); + $scope.isAuthenticated = false; + + // Handle login errors here + $scope.username_password_error = datum.error; + }); + }; + + $scope.logout = function () { + userService.clearUser(); + $scope.isAuthenticated = false; + }; + + $scope.signupPassword = function () { + $scope.signup.naUser.userId = 0; + $http. + post(`(showURL (Account Nothing) [])`, $scope.signup). + success(function (datum, status, headers, config) { + $scope.signup_error = 'Account Created'; // FIXME -- I18N + $scope.signup = {}; + }). + error(function (datum, status, headers, config) { + $scope.signup_error = datum.error; + }); + }; + + $scope.changePassword = function (url) { + var u = userService.getUser(); + if (u.isAuthenticated) { + $http. + post(url, $scope.password). + success(function (datum, status, headers, config) { + $scope.change_password_error = 'Password Changed.'; // FIXME -- I18N + $scope.password = {}; + }). + error(function (datum, status, headers, config) { + $scope.change_password_error = datum.error; + }); + } else { + $scope.change_password_error = 'Not Authenticated.'; // FIXME -- I18N + } + }; + + $scope.requestResetPassword = function () { + $http.post(`(showURL PasswordRequestReset [])`, $scope.requestReset). + success(function (datum, status, headers, config) { + $scope.request_reset_password_msg = datum; + }). + error(function (datum, status, headers, config) { + $scope.request_reset_password_msg = datum.error; + }); + }; + + $scope.resetPassword = function () { + var resetToken = $location.search().reset_token; + if (resetToken) { + $scope.reset.rpResetToken = resetToken; + $http.post(`(showURL PasswordReset [])`, $scope.reset). + success(function (datum, status, headers, config) { + $scope.reset_password_msg = datum; + }). + error(function (datum, status, headers, config) { + $scope.reset_password_msg = datum.error; + }); + } else { + $scope.reset_password_msg = "reset token not found."; // FIXME -- I18N + } + }; + + }]); + + openId.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 + } + return $q.reject(rejection); + } + }; + }]); + + openId.config(['$httpProvider', function ($httpProvider) { + $httpProvider.interceptors.push('authInterceptor'); + }]); + + // upAuthenticated directive + openId.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); + } + }); + } + }; + }]); + + // upLoginInline directive + openId.directive('upLoginInline', ['$rootScope', 'userService', function ($rootScope, userService) { + return { + restrict: 'E', +// replace: true, + templateUrl: `(showURL (Partial LoginInline) [])` + }; + }]); + + // upChangePassword directive + openId.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 +// templateUrl: `(showURL (Partial ChangePassword) [])` +// template: "<div ng-include=\"'" + `(showURL (Partial ChangePassword) [])` + "'\"></div>" +// template: "<div ng-include=\"'/authenticate/authentication-methods/password/partial/change-password'\"></div>" + }; + /* + return { + restrict: 'E', + templateUrl: `(showURL (Partial ChangePassword) [])` + }; +*/ + }]); + + + // upRequestResetPassword directive + openId.directive('upRequestResetPassword', [function () { + return { + restrict: 'E', +// replace: true, + templateUrl: `(showURL (Partial RequestResetPasswordForm) [])` + }; + }]); + + // upResetPassword directive + openId.directive('upResetPassword', [function () { + return { + restrict: 'E', +// replace: true, + templateUrl: `(showURL (Partial ResetPasswordForm) [])` + }; + }]); + + openId.directive('upSignupPassword', [function () { + return { + restrict: 'E', +// replace: true, + templateUrl: `(showURL (Partial SignupPassword) [])` + }; + }]); + + + } + |] +-} diff --git a/Happstack/Authenticate/OpenId/Core.hs b/Happstack/Authenticate/OpenId/Core.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/Core.hs @@ -0,0 +1,241 @@ +{-# 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 GHC.Generics (Generic) +import Happstack.Authenticate.Core (AuthenticateState, UserId(..), 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 (withManager) +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) +deriveSafeCopy 2 'extension ''OpenIdState +makeLenses ''OpenIdState + +instance Migrate OpenIdState where + type MigrateFrom OpenIdState = OpenIdState_1 + migrate (OpenIdState_1 ids) = OpenIdState ids Nothing + +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 $ withManager $ authenticateClaimed pairs + return (oirOpLocal oir) + +token :: (Alternative m, Happstack m) => + AcidState AuthenticateState + -> (UserId -> IO Bool) + -> AcidState OpenIdState + -> m Response +token authenticateState isAuthAdmin 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 isAuthAdmin 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) + +-} diff --git a/Happstack/Authenticate/OpenId/Partials.hs b/Happstack/Authenticate/OpenId/Partials.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/Partials.hs @@ -0,0 +1,228 @@ +{-# 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 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, UserId(..), 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 (google, 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 + = UsingGoogleMsg + | 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 + UsingGoogle -> usingGoogle + UsingYahoo -> usingYahoo + RealmForm -> realmForm openIdState + +usingGoogle :: (Functor m, Monad m) => + Partial m XML +usingGoogle = + do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack google)) + [hsx| + <a ng-click=("openIdWindow('" <> danceURL <> "')")><img src="https://raw.githubusercontent.com/intridea/authbuttons/master/png/google_32.png" alt=UsingGoogleMsg /></a> + |] + +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/intridea/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"> + <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>{{set_openid_realm_msg}}</div> + </div> + |] + +{- +signupPasswordForm :: (Functor m, Monad m) => + Partial m XML +signupPasswordForm = + [hsx| + <form ng-submit="signupPassword()" role="form"> + <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" 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" 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" 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" placeholder=PasswordConfirmationMsg /> + </div> + <div class="form-group"> + <input class="form-control" type="submit" value=SignUpMsg /> + </div> + <div>{{signup_error}}</div> + </form> + |] + +usernamePasswordForm :: (Functor m, Monad m) => + Partial m XML +usernamePasswordForm = [hsx| + <div> + <div ng-show="!isAuthenticated"> + <form ng-submit="login()" role="form" class="navbar-form navbar-right"> + <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> + <div>{{username_password_error}}</div> + </div> + <div ng-show="isAuthenticated"> + <a class="navbar-right" ng-click="logout()" href=""><% LogoutMsg %></a> + </div> + </div> + |] + +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"> + <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> + <div>{{change_password_error}}</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"> + <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>{{request_reset_password_msg}}</div> + </div> + |] + +resetPasswordForm :: (Functor m, MonadIO m) => + Partial m XML +resetPasswordForm = + [hsx| + <div> + <form ng-submit="resetPassword()" role="form"> + <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>{{reset_password_msg}}</div> + </div> + |] +-} diff --git a/Happstack/Authenticate/OpenId/PartialsURL.hs b/Happstack/Authenticate/OpenId/PartialsURL.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/PartialsURL.hs @@ -0,0 +1,29 @@ +{-# 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 + = UsingGoogle + | UsingYahoo + | RealmForm + deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) + +makeBoomerangs ''PartialURL + +partialURL :: Router () (PartialURL :- ()) +partialURL = + ( "using-google" . rUsingGoogle + <> "using-yahoo" . rUsingYahoo + <> "realm" . rRealmForm + ) + +instance PathInfo PartialURL where + fromPathSegments = boomerangFromPathSegments partialURL + toPathSegments = boomerangToPathSegments partialURL diff --git a/Happstack/Authenticate/OpenId/Route.hs b/Happstack/Authenticate/OpenId/Route.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/Route.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +module Happstack.Authenticate.OpenId.Route where + +import Control.Applicative ((<$>)) +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 Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateState, AuthenticateURL, CoreError(..), UserId, 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 (withManager) +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 + -> (UserId -> IO Bool) + -> AcidState OpenIdState + -> [Text] + -> RouteT AuthenticateURL (ReaderT [Lang] m) Response +routeOpenId authenticateState isAuthAdmin openIdState pathSegments = + case parseSegments fromPathSegments pathSegments of + (Left _) -> notFound $ toJSONError URLDecodeFailed + (Right url) -> + 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 $ withManager $ getForwardUrl providerURL returnURL realm [] -- [("Email", "http://schema.openid.net/contact/email")] + seeOther forwardURL (toResponse ()) + ReturnTo -> token authenticateState isAuthAdmin openIdState + Realm -> realm authenticateState openIdState + +------------------------------------------------------------------------------ +-- initOpenId +------------------------------------------------------------------------------ + +initOpenId :: FilePath + -> AcidState AuthenticateState + -> (UserId -> IO Bool) + -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) +initOpenId basePath authenticateState isAuthAdmin = + 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 isAuthAdmin openIdState pathSegments + return (shutdown, (openIdAuthenticationMethod, authenticationHandler), openIdCtrl authenticateState openIdState) + diff --git a/Happstack/Authenticate/OpenId/URL.hs b/Happstack/Authenticate/OpenId/URL.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/OpenId/URL.hs @@ -0,0 +1,52 @@ +{-# 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 GHC.Generics (Generic) +import Prelude hiding ((.), id) +import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), UserId(..), nestAuthenticationMethod, rUserId) +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 + diff --git a/Happstack/Authenticate/Password/Controllers.hs b/Happstack/Authenticate/Password/Controllers.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/Controllers.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE QuasiQuotes #-} +module Happstack.Authenticate.Password.Controllers where + +import Data.Text (Text) +import qualified Data.Text as T +import Happstack.Authenticate.Core (AuthenticateURL) +import Happstack.Authenticate.Password.URL (PasswordURL(Account, Token, Partial, PasswordReset, PasswordRequestReset), nestPasswordURL) +import Happstack.Authenticate.Password.PartialsURL (PartialURL(ChangePassword, Logout, LoginInline, SignupPassword, ResetPasswordForm, RequestResetPasswordForm)) +import Language.Javascript.JMacro +import Web.Routes + +usernamePasswordCtrl :: (Monad m) => RouteT AuthenticateURL m JStat +usernamePasswordCtrl = + nestPasswordURL $ + do fn <- askRouteFn + return $ usernamePasswordCtrlJs fn + +usernamePasswordCtrlJs :: (PasswordURL -> [(Text, Maybe Text)] -> Text) -> JStat +usernamePasswordCtrlJs showURL = [jmacro| + { + var usernamePassword = angular.module('usernamePassword', ['happstackAuthentication']); + + usernamePassword.controller('UsernamePasswordCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService) { +/* $scope.isAuthenticated = userService.getUser().isAuthenticated; + + $scope.$watch(function () { return userService.getUser().isAuthenticated; }, function(newVal, oldVal) { $scope.isAuthenticated = newVal; }); +*/ + $scope.login = function () { + $http. + post(`(showURL Token [])`, $scope.user). + success(function (datum, status, headers, config) { + $scope.username_password_error = ''; +// $scope.isAuthenticated = true; + userService.updateFromToken(datum.token); + }). + error(function (datum, status, headers, config) { + // Erase the token if the user fails to log in + userService.clearUser(); +// $scope.isAuthenticated = false; + + // Handle login errors here + $scope.username_password_error = datum.error; + }); + }; + + $scope.signupPassword = function () { + $scope.signup.naUser.userId = 0; + $http. + post(`(showURL (Account Nothing) [])`, $scope.signup). + success(function (datum, status, headers, config) { + $scope.signup_error = 'Account Created'; // FIXME -- I18N + $scope.signup = {}; + }). + error(function (datum, status, headers, config) { + $scope.signup_error = datum.error; + }); + }; + + $scope.changePassword = function (url) { + var u = userService.getUser(); + if (u.isAuthenticated) { + $http. + post(url, $scope.password). + success(function (datum, status, headers, config) { + $scope.change_password_error = 'Password Changed.'; // FIXME -- I18N + $scope.password = {}; + }). + error(function (datum, status, headers, config) { + $scope.change_password_error = datum.error; + }); + } else { + $scope.change_password_error = 'Not Authenticated.'; // FIXME -- I18N + } + }; + + $scope.requestResetPassword = function () { + $http.post(`(showURL PasswordRequestReset [])`, $scope.requestReset). + success(function (datum, status, headers, config) { + $scope.request_reset_password_msg = datum; + }). + error(function (datum, status, headers, config) { + $scope.request_reset_password_msg = datum.error; + }); + }; + + $scope.resetPassword = function () { + var resetToken = $location.search().reset_token; + if (resetToken) { + $scope.reset.rpResetToken = resetToken; + $http.post(`(showURL PasswordReset [])`, $scope.reset). + success(function (datum, status, headers, config) { + $scope.reset_password_msg = datum; + }). + error(function (datum, status, headers, config) { + $scope.reset_password_msg = datum.error; + }); + } 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 + } + 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) [])` + }; + }]); + + // 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) [])` + }; + }]); + + + } + |] diff --git a/Happstack/Authenticate/Password/Core.hs b/Happstack/Authenticate/Password/Core.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/Core.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} +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) +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 ((<>)) +import Data.SafeCopy (SafeCopy, base, 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 GHC.Generics (Generic) +import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod(..), AuthenticateState(..), AuthenticateURL, CoreError(..), CreateUser(..), Email(..), GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), UserId(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, email, getToken, getOrGenSharedSecret, issueToken, jsonOptions, userId, username, 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, sendmail) +import System.FilePath (combine) +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, secret, secondsSinceEpoch, verify) +import Web.Routes +import Web.Routes.TH + +------------------------------------------------------------------------------ +-- PasswordError +------------------------------------------------------------------------------ + +data PasswordError + = NotAuthenticated + | NotAuthorized + | InvalidUsername + | InvalidPassword + | InvalidUsernamePassword + | NoEmailAddress + | MissingResetToken + | InvalidResetToken + | PasswordMismatch + | 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 + -> (UserId -> IO Bool) + -> AcidState PasswordState + -> m Response +token authenticateState isAuthAdmin 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 isAuthAdmin u + resp 201 $ toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)] + +------------------------------------------------------------------------------ +-- 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 + -> 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 Nothing = + do method POST + (Just (Body body)) <- takeRequestBody =<< askRq + case Aeson.decode body of + Nothing -> badRequest (Left $ CoreError JSONDecodeFailed) + (Just newAccount) -> + 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) + ok $ (Right (user ^. userId)) +-- handle updates to /account/<userId>/* +account authenticateState passwordState (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 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) => + Text + -> Text + -> AcidState AuthenticateState + -> AcidState PasswordState + -> m (Either PasswordError Text) +passwordRequestReset resetLink domain 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 eResetToken <- issueResetToken authenticateState user + case eResetToken of + (Left err) -> return (Left err) + (Right resetToken) -> + do let resetLink' = resetLink <> (Text.decodeUtf8 $ renderQuery True $ toQuery [("reset_token"::Text, resetToken)]) +-- liftIO $ Text.putStrLn resetLink' -- FIXME: don't print to stdout + sendResetEmail toEm (Email ("no-rneplay@" <> domain)) resetLink' + return (Right "password reset request email sent.") -- FIXME: I18N + +-- | issueResetToken +issueResetToken :: (MonadIO m) => + AcidState AuthenticateState + -> User + -> m (Either PasswordError JWT.JSON) +issueResetToken authenticateState user = + case user ^. email of + Nothing -> return (Left NoEmailAddress) + (Just addr) -> + do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) + -- FIXME: add expiration time + now <- liftIO getPOSIXTime + let claims = JWT.def { unregisteredClaims = Map.singleton "reset-password" (toJSON user) + , JWT.exp = intDate $ now + 60 + } + return $ Right $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims + +-- FIXME: I18N +-- FIXME: call renderSendMail +sendResetEmail :: (MonadIO m) => + Email + -> Email + -> Text + -> m () +sendResetEmail (Email toEm) (Email fromEm) resetLink = liftIO $ + do mailBS <- renderMail' $ simpleMail' (Address Nothing toEm) (Address (Just "no-reply") fromEm) "Reset Password Request" (LT.fromStrict resetLink) + -- B.putStr mailBS + sendmail mailBS + +-- | 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 + -> m (Either PasswordError ()) +passwordReset authenticateState passwordState = + 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 do pw <- mkHashedPass password + update' passwordState (SetPassword (user ^. userId) pw) + ok $ Right () + + {- + 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" (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) -> + case verify (secret (_unSharedSecret ssecret)) unverified of + 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)) diff --git a/Happstack/Authenticate/Password/Forms.hs b/Happstack/Authenticate/Password/Forms.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/Forms.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes #-} +module Happstack.Authenticate.Password.Forms where + +import HSP +import Happstack.Server.HSP.HTML () +import Language.Haskell.HSX.QQ (hsx) +import Happstack.Authenticate.Core (AuthenticateURL) +import Happstack.Authenticate.Password.URL (PasswordURL) +import Web.Routes +import Web.Routes.XMLGenT () + +-- usernamePasswordDiv x = +-- <div ng-controller="UsernamePasswordCtrl"> + +-- FIXME: there should be a way to include this via an angular directive +usernamePasswordForm :: (Functor m, Monad m) => + XMLGenT (RouteT AuthenticateURL m) XML +usernamePasswordForm = [hsx| + <div> + <div ng-show="!isAuthenticated"> + <form ng-submit="login()" role="form" class="form-inline"> + <div class="form-group"> + <label class="sr-only" for="username">username</label> + <input class="form-control" ng-model="user.user" type="text" id="username" name="user" placeholder="Username" /> + </div><% " " %> + <div class="form-group"> + <label class="sr-only" for="password">password</label> + <input class="form-control" ng-model="user.password" type="password" id="password" name="pass" placeholder="Password" /> + </div><% " " %> + <div class="form-group"> + <input class="form-control" type="submit" value="Sign in" /> + </div> + </form> + <div>{{username_password_error}}</div> + </div> + <div ng-show="isAuthenticated"> + <a ng-click="logout()" href="">Logout</a> + </div> + </div> + |] diff --git a/Happstack/Authenticate/Password/Partials.hs b/Happstack/Authenticate/Password/Partials.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/Partials.hs @@ -0,0 +1,205 @@ +{-# 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 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, UserId(..), 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 + Logout -> logoutForm + SignupPassword -> signupPasswordForm + ChangePassword -> + do mUser <- getToken authenticateState + case mUser of + Nothing -> [hsx| <p><% show NotAuthenticated %></p> |] + (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 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" 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" 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" 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" placeholder=PasswordConfirmationMsg /> + </div> + <div class="form-group"> + <input class="form-control" type="submit" value=SignUpMsg /> + </div> + <div>{{signup_error}}</div> + </form> + |] + +usernamePasswordForm :: (Functor m, Monad m) => + Partial m XML +usernamePasswordForm = [hsx| + <span> + <span ng-show="!isAuthenticated"> + <form ng-submit="login()" role="form" class="navbar-form navbar-left"> + <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> + <div>{{username_password_error}}</div> + </span> + </span> + |] + +logoutForm :: (Functor m, MonadIO m) => Partial m XML +logoutForm = [hsx| + <span ng-show="isAuthenticated"> + <div class="form-group"> + <a class="navbar-right" 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"> + <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> + <div>{{change_password_error}}</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"> + <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>{{request_reset_password_msg}}</div> + </div> + |] + +resetPasswordForm :: (Functor m, MonadIO m) => + Partial m XML +resetPasswordForm = + [hsx| + <div> + <form ng-submit="resetPassword()" role="form"> + <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>{{reset_password_msg}}</div> + </div> + |] diff --git a/Happstack/Authenticate/Password/PartialsURL.hs b/Happstack/Authenticate/Password/PartialsURL.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/PartialsURL.hs @@ -0,0 +1,36 @@ +{-# 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 + | Logout + | SignupPassword + | ChangePassword + | RequestResetPasswordForm + | ResetPasswordForm + deriving (Eq, Ord, Data, Typeable, Generic) + +makeBoomerangs ''PartialURL + +partialURL :: Router () (PartialURL :- ()) +partialURL = + ( "login-inline" . rLoginInline + <> "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 diff --git a/Happstack/Authenticate/Password/Route.hs b/Happstack/Authenticate/Password/Route.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/Route.hs @@ -0,0 +1,68 @@ +module Happstack.Authenticate.Password.Route where + +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Acid (AcidState, closeAcidState, makeAcidic) +import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) +import Data.Text (Text) +import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateState, AuthenticateURL, CoreError(..), UserId, toJSONError, toJSONResponse) +import Happstack.Authenticate.Password.Core (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) => + Text + -> Text + -> AcidState AuthenticateState + -> (UserId -> IO Bool) + -> AcidState PasswordState + -> [Text] + -> RouteT AuthenticateURL (ReaderT [Lang] m) Response +routePassword resetLink domain authenticateState isAuthAdmin passwordState pathSegments = + case parseSegments fromPathSegments pathSegments of + (Left _) -> notFound $ toJSONError URLDecodeFailed + (Right url) -> + case url of + Token -> token authenticateState isAuthAdmin passwordState + Account mUrl -> toJSONResponse <$> account authenticateState passwordState mUrl + (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u) + ok $ toResponse (html4StrictFrag, xml) + PasswordRequestReset -> toJSONResponse <$> passwordRequestReset resetLink domain authenticateState passwordState + PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState + UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl + +------------------------------------------------------------------------------ +-- initPassword +------------------------------------------------------------------------------ + +initPassword :: Text + -> Text + -> FilePath + -> AcidState AuthenticateState + -> (UserId -> IO Bool) + -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) +initPassword resetLink domain basePath authenticateState isAuthAdmin = + do passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState + 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 resetLink domain authenticateState isAuthAdmin passwordState pathSegments + return (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl) diff --git a/Happstack/Authenticate/Password/URL.hs b/Happstack/Authenticate/Password/URL.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Password/URL.hs @@ -0,0 +1,76 @@ +{-# 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 GHC.Generics (Generic) +import Prelude hiding ((.), id) +import Web.Routes (RouteT(..)) +import Web.Routes.TH (derivePathInfo) +import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), UserId(..), nestAuthenticationMethod, rUserId) +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 + diff --git a/Happstack/Authenticate/Route.hs b/Happstack/Authenticate/Route.hs new file mode 100644 --- /dev/null +++ b/Happstack/Authenticate/Route.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} +module Happstack.Authenticate.Route where + +import Control.Applicative ((<$>)) +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 HSP.JMacro (IntegerSupply(..)) +import Happstack.Authenticate.Controller (authenticateCtrl) +import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL(..), AuthenticationHandler, AuthenticationHandlers, AuthenticationMethod, CoreError(HandlerNotFound), UserId, 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 + -> (UserId -> IO Bool) + -> [FilePath -> AcidState AuthenticateState -> (UserId -> IO Bool) -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)] + -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState) +initAuthentication mBasePath isAuthAdmin initMethods = + do let authenticatePath = combine (fromMaybe "state" mBasePath) "authenticate" + authenticateState <- openLocalStateFrom (combine authenticatePath "core") initialAuthenticateState + -- FIXME: need to deal with one of the initMethods throwing an exception + (cleanupPartial, handlers, javascript) <- unzip3 <$> mapM (\initMethod -> initMethod authenticatePath authenticateState isAuthAdmin) initMethods + let cleanup = sequence_ $ createCheckpointAndClose authenticateState : (map (\c -> c True) cleanupPartial) + h = route javascript (Map.fromList handlers) + return (cleanup, h, authenticateState) + +instance (Functor m, MonadIO m) => IntegerSupply (RouteT AuthenticateURL m) where + nextInteger = + fmap (fromIntegral . (`mod` 1024) . hashUnique) (liftIO newUnique) diff --git a/happstack-authenticate.cabal b/happstack-authenticate.cabal --- a/happstack-authenticate.cabal +++ b/happstack-authenticate.cabal @@ -1,5 +1,5 @@ Name: happstack-authenticate -Version: 0.10.16 +Version: 2.1.3 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ @@ -7,50 +7,67 @@ 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 - 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 + Exposed-modules: Happstack.Authenticate.Core + Happstack.Authenticate.Controller + Happstack.Authenticate.Route + Happstack.Authenticate.Password.Controllers + Happstack.Authenticate.Password.Core + Happstack.Authenticate.Password.Forms + 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.14, + aeson >= 0.4 && < 0.9, 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.5, - 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.1, + boomerang >= 1.4 && < 1.5, + bytestring >= 0.9 && < 0.11, + containers >= 0.4 && < 0.6, + data-default >= 0.5 && < 0.6, + filepath >= 1.3 && < 1.5, + hsx2hs >= 0.13 && < 0.14, + jmacro >= 0.6.11 && < 0.7, + jwt >= 0.3 && < 0.7, + ixset-typed >= 0.3 && < 0.4, + happstack-jmacro >= 7.0 && < 7.1, + happstack-server >= 6.0 && < 7.5, + happstack-hsp >= 7.3 && < 7.4, + http-conduit >= 1.4 && < 2.2, + http-types >= 0.6 && < 0.9, + hsp >= 0.10 && < 0.11, + hsx-jmacro >= 7.3 && < 7.4, + safecopy >= 0.8 && < 0.9, + mime-mail >= 0.4 && < 0.5, + mtl >= 2.0 && < 2.3, + lens >= 4.2 && < 4.10, 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.*, + time >= 1.2 && < 1.6, + random >= 1.0 && < 1.2, + 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