yesod-auth 1.1.7 → 1.6.12.1
raw patch · 16 files changed
Files
- ChangeLog.md +240/−0
- README.md +12/−0
- Yesod/Auth.hs +441/−128
- Yesod/Auth/BrowserId.hs +102/−54
- Yesod/Auth/Dummy.hs +57/−11
- Yesod/Auth/Email.hs +999/−283
- Yesod/Auth/GoogleEmail.hs +0/−102
- Yesod/Auth/GoogleEmail2.hs +616/−0
- Yesod/Auth/Hardcoded.hs +198/−0
- Yesod/Auth/HashDB.hs +0/−316
- Yesod/Auth/Message.hs +612/−23
- Yesod/Auth/OpenId.hs +44/−51
- Yesod/Auth/Routes.hs +23/−0
- Yesod/Auth/Rpxnow.hs +13/−16
- Yesod/Auth/Util/PasswordStore.hs +457/−0
- yesod-auth.cabal +52/−32
+ ChangeLog.md view
@@ -0,0 +1,240 @@+# ChangeLog for yesod-auth++## 1.6.12.1++* Support `yesod-core` 1.7++## 1.6.12.0++* Add `afterPasswordRouteHandler` [#1863](https://github.com/yesodweb/yesod/pull/1863)+* Use crypton instead of cryptonite [#1838](https://github.com/yesodweb/yesod/pull/1838)+* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)+++## 1.6.11.3++* Add Romanian translation [#1809](https://github.com/yesodweb/yesod/pull/1809)++## 1.6.11.2++* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)++## 1.6.11.1++* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)++## 1.6.11++* Add support for aeson 2++## 1.6.10.5++* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)++## 1.6.10.4++* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)++## 1.6.10.3++* Relax bounds for yesod-form 1.7++## 1.6.10.2++* Relax bounds for persistent 2.12++## 1.6.10.1++* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)++## 1.6.10++* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`+* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration+* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password+* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)++## 1.6.9++* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)+* Exposed `defaultRegisterHelper` as default implementation for the above methods++## 1.6.8.1++* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)+* Remove unnecessary deriving of Typeable++## 1.6.8++* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)++## 1.6.7++* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)++## 1.6.6++* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)++## 1.6.5++* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)++## 1.6.4.1++* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)++## 1.6.4++* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)+* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389)+To configure this new functionality:+ 1. Define `addUnverifiedWithPass`, e.g:+ ```+ addUnverified email verkey = liftHandler $ runDB $ do+ void $ insert $ UserLogin email Nothing (Just verkey) False+ return email++ addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do+ void $ insert $ UserLogin email (Just pass) (Just verkey) False+ return email+ ```+ 2. Add a `password` field to your client forms.++## 1.6.3++* Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)++## 1.6.2++* Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)++## 1.6.1++* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)++## 1.6.0++* Upgrade to yesod-core 1.6.0++## 1.4.21++* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)++## 1.4.20++* Extend `YesodAuthEmail` to support extensible password hashing via+ `hashAndSaltPassword` and `verifyPassword` functions++## 1.4.19++* Adjust English localization to distinguish between "log in" (verb) and "login" (noun)++## 1.4.18++* Expose Yesod.Auth.Util.PasswordStore++## 1.4.17.3++* Some translation fixes++## 1.4.17.2++* Move to cryptonite from cryptohash++## 1.4.17.1++* Some translation fixes++## 1.4.17++* Add Show instance for user credentials `Creds`+* Export pid type for identifying plugin+* Fix warnings+* Allow for a custom Email Login DOM with `emailLoginHandler`++## 1.4.16++* Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330)+* Document JSON endpoints of Yesod.Auth.Email++## 1.4.15++* Add JSON endpoints to Yesod.Auth.Email module+* Export croatianMessage from Message module+* Minor Haddock rendering fixes at Auth.Email module++## 1.4.14++* Remove Google OpenID link [#1309](https://github.com/yesodweb/yesod/pull/1309)+* Add CSRF Security check in `registerHelperFunction` [#1302](https://github.com/yesodweb/yesod/pull/1302)++## 1.4.13.5++* Translation fix++## 1.4.13.4++* Improved translations+* peristent 2.6++## 1.4.13.3++* Doc update (and a warning)++## 1.4.13.1++* Add CSRF token to login form from `Yesod.Auth.Dummy` [#1205](https://github.com/yesodweb/yesod/pull/1205)++## 1.4.13++* Add a CSRF token to the login form from `Yesod.Auth.Hardcoded`, making it compatible with the CSRF middleware [#1161](https://github.com/yesodweb/yesod/pull/1161)+* Multiple session messages. [#1187](https://github.com/yesodweb/yesod/pull/1187)++## 1.4.12++* Deprecated Yesod.Auth.GoogleEmail++## 1.4.11++Add Yesod.Auth.Hardcoded++## 1.4.9++* Expose defaultLoginHandler++## 1.4.8++* GoogleEmail2: proper error message when permission denied++## 1.4.7++* add a runHttpRequest function for handling HTTP errors++## 1.4.6++* Use nonce package to generate verification keys and CSRF tokens [#1011](https://github.com/yesodweb/yesod/pull/1011)++## 1.4.5++* Adds export of email verify route [#980](https://github.com/yesodweb/yesod/pull/980)++## 1.4.4++* Add AuthenticationResult and authenticate function [#959](https://github.com/yesodweb/yesod/pull/959)++## 1.4.3++* Added means to fetch user's Google profile [#936](https://github.com/yesodweb/yesod/pull/936)++## 1.4.2++* Perform `onLogout` before session cleaning [#923](https://github.com/yesodweb/yesod/pull/923)++## 1.4.1.3++[Updated french translation of Yesod.Auth.Message. #904](https://github.com/yesodweb/yesod/pull/904)++## 1.4.1++Dutch translation added.
+ README.md view
@@ -0,0 +1,12 @@+## yesod-auth++This package provides a pluggable mechanism for allowing users to authenticate+with your site. It comes with a number of common plugins, such as OpenID,+BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available+from Hackage as well. If you've written such an add-on, please notify me so+that it can be added to this description.++* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0.+* [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod+* [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.+* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
Yesod/Auth.hs view
@@ -1,12 +1,18 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Yesod.Auth ( -- * Subsite Auth@@ -15,55 +21,82 @@ , AuthPlugin (..) , getAuth , YesodAuth (..)+ , YesodAuthPersist (..) -- * Plugin interface , Creds (..) , setCreds+ , setCredsRedirect , clearCreds+ , loginErrorMessage+ , loginErrorMessageI -- * User functions+ , AuthenticationResult (..) , defaultMaybeAuthId+ , defaultLoginHandler+ , maybeAuthPair , maybeAuth , requireAuthId+ , requireAuthPair , requireAuth -- * Exception , AuthException (..)+ -- * Helper+ , MonadAuthHandler+ , AuthHandler+ -- * Internal+ , credsKey+ , provideJsonMessage+ , messageJson401+ , asHtml ) where -import Control.Monad (when) +import Control.Monad (when) import Control.Monad.Trans.Maybe -import Data.Aeson+import Yesod.Auth.Routes import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Lazy as Map-import Network.HTTP.Conduit (Manager)--import Language.Haskell.TH.Syntax hiding (lift)+import Data.Monoid (Endo)+import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)+import Network.HTTP.Client.TLS (getGlobalManager) import qualified Network.Wai as W-import Text.Hamlet (shamlet) import Yesod.Core import Yesod.Persist-import Yesod.Json import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception)--data Auth = Auth+import Network.HTTP.Types (Status, internalServerError500, unauthorized401)+import qualified Control.Monad.Trans.Writer as Writer+import Control.Monad (void)+import Data.Kind (Type) type AuthRoute = Route Auth +type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)+type AuthHandler master a = forall m. MonadAuthHandler master m => m a+ type Method = Text type Piece = Text +-- | The result of an authentication based on credentials+--+-- @since 1.4.4+data AuthenticationResult master+ = Authenticated (AuthId master) -- ^ Authenticated successfully+ | UserError AuthMessage -- ^ Invalid credentials provided by user+ | ServerError Text -- ^ Some other error+ data AuthPlugin master = AuthPlugin { apName :: Text- , apDispatch :: Method -> [Piece] -> GHandler Auth master ()- , apLogin :: forall sub. (Route Auth -> Route master) -> GWidget sub master ()+ , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent+ , apLogin :: (Route Auth -> Route master) -> WidgetFor master () } getAuth :: a -> Auth@@ -74,11 +107,15 @@ { credsPlugin :: Text -- ^ How the user was authenticated , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. , credsExtra :: [(Text, Text)]- }+ } deriving (Show) class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where type AuthId master + -- | specify the layout. Uses defaultLayout by default+ authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html+ authLayout = liftHandler . defaultLayout+ -- | Default destination on successful login, if no other -- destination exists. loginDest :: master -> Route master@@ -87,24 +124,59 @@ -- destination exists. logoutDest :: master -> Route master + -- | Perform authentication based on the given credentials.+ --+ -- Default implementation is in terms of @'getAuthId'@+ --+ -- @since: 1.4.4+ authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)+ authenticate creds = do+ muid <- getAuthId creds++ return $ maybe (UserError Msg.InvalidLogin) Authenticated muid+ -- | Determine the ID associated with the set of credentials.- getAuthId :: Creds master -> GHandler sub master (Maybe (AuthId master))+ --+ -- Default implementation is in terms of @'authenticate'@+ --+ getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))+ getAuthId creds = do+ auth <- authenticate creds + return $ case auth of+ Authenticated auid -> Just auid+ _ -> Nothing+ -- | Which authentication backends to use. authPlugins :: master -> [AuthPlugin master] -- | What to show on the login page.- loginHandler :: GHandler Auth master RepHtml- loginHandler = defaultLayout $ do- setTitleI Msg.LoginTitle- tm <- lift getRouteToMaster- master <- lift getYesod- mapM_ (flip apLogin tm) (authPlugins master)+ --+ -- By default this calls 'defaultLoginHandler', which concatenates+ -- plugin widgets and wraps the result in 'authLayout'. Override if+ -- you need fancy widget containers, additional functionality, or an+ -- entirely custom page. For example, in some applications you may+ -- want to prevent the login page being displayed for a user who is+ -- already logged in, even if the URL is visited explicitly; this can+ -- be done by overriding 'loginHandler' in your instance declaration+ -- with something like:+ --+ -- > instance YesodAuth App where+ -- > ...+ -- > loginHandler = do+ -- > ma <- lift maybeAuthId+ -- > when (isJust ma) $+ -- > lift $ redirect HomeR -- or any other Handler code you want+ -- > defaultLoginHandler+ --+ loginHandler :: AuthHandler master Html+ loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package. renderAuthMessage :: master -> [Text] -- ^ languages- -> AuthMessage -> Text+ -> AuthMessage+ -> Text renderAuthMessage _ _ = defaultMessage -- | After login and logout, redirect to the referring page, instead of@@ -112,19 +184,27 @@ redirectToReferer :: master -> Bool redirectToReferer _ = False + -- | When being redirected to the login page should the current page+ -- be set to redirect back to. Default is 'True'.+ --+ -- @since 1.4.21+ redirectToCurrent :: master -> Bool+ redirectToCurrent _ = True+ -- | Return an HTTP connection manager that is stored in the foundation -- type. This allows backends to reuse persistent connections. If none of -- the backends you're using use HTTP connections, you can safely return- -- @error \"authHttpManager"@ here.- authHttpManager :: master -> Manager+ -- @error \"authHttpManager\"@ here.+ authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager+ authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls- -- @setMessageI NowLoggedIn@.- onLogin :: GHandler sub master ()- onLogin = setMessageI Msg.NowLoggedIn+ -- @addMessageI "success" NowLoggedIn@.+ onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()+ onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing- onLogout :: GHandler sub master ()+ onLogout :: (MonadHandler m, master ~ HandlerSite m) => m () onLogout = return () -- | Retrieves user credentials, if user is authenticated.@@ -135,79 +215,234 @@ -- especially useful for creating an API to be accessed via some means -- other than a browser. --- -- Since 1.1.2- maybeAuthId :: GHandler sub master (Maybe (AuthId master))+ -- @since 1.2.0+ maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))++ default maybeAuthId+ :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))+ => m (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId + -- | Called on login error for HTTP requests. By default, calls+ -- @addMessage@ with "error" as status and redirects to @dest@.+ onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html+ onErrorHtml dest msg = do+ addMessage "error" $ toHtml msg+ fmap asHtml $ redirect dest++ -- | runHttpRequest gives you a chance to handle an HttpException and retry+ -- The default behavior is to simply execute the request which will throw an exception on failure+ --+ -- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.+ -- This is an experimental API that is not broadly used throughout the yesod-auth code base+ runHttpRequest+ :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)+ => Request+ -> (Response BodyReader -> m a)+ -> m a+ runHttpRequest req inner = do+ man <- authHttpManager+ withRunInIO $ \run -> withResponse req man $ run . inner++ {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}++{-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}++-- | Internal session key used to hold the authentication information.+--+-- @since 1.2.3 credsKey :: Text credsKey = "_ID" -- | Retrieves user credentials from the session, if user is authenticated. ----- Since 1.1.2-defaultMaybeAuthId :: YesodAuth master- => GHandler sub master (Maybe (AuthId master))-defaultMaybeAuthId = do- ms <- lookupSession credsKey- case ms of- Nothing -> return Nothing- Just s -> return $ fromPathPiece s+-- This function does /not/ confirm that the credentials are valid, see+-- 'maybeAuthIdRaw' for more information. The first call in a request+-- does a database request to make sure that the account is still in the database.+--+-- @since 1.1.2+defaultMaybeAuthId+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))+ => m (Maybe (AuthId master))+defaultMaybeAuthId = runMaybeT $ do+ s <- MaybeT $ lookupSession credsKey+ aid <- MaybeT $ return $ fromPathPiece s+ _ <- MaybeT $ cachedAuth aid+ return aid -mkYesodSub "Auth"- [ ClassP ''YesodAuth [VarT $ mkName "master"]- ]-#define STRINGS *Texts- [parseRoutes|-/check CheckR GET-/login LoginR GET-/logout LogoutR GET POST-/page/#Text/STRINGS PluginR-|]+cachedAuth+ :: ( MonadHandler m+ , YesodAuthPersist master+ , Typeable (AuthEntity master)+ , HandlerSite m ~ master+ )+ => AuthId master+ -> m (Maybe (AuthEntity master))+cachedAuth+ = fmap unCachedMaybeAuth+ . cached+ . fmap CachedMaybeAuth+ . getAuthEntity --- | Sets user credentials for the session after checking them with authentication backends.-setCreds :: YesodAuth master- => Bool -- ^ if HTTP redirects should be done- -> Creds master -- ^ new credentials- -> GHandler sub master ()-setCreds doRedirects creds = do++-- | Default handler to show the login page.+--+-- This is the default 'loginHandler'. It concatenates plugin widgets and+-- wraps the result in 'authLayout'. See 'loginHandler' for more details.+--+-- @since 1.4.9+defaultLoginHandler :: AuthHandler master Html+defaultLoginHandler = do+ tp <- getRouteToParent+ authLayout $ do+ setTitleI Msg.LoginTitle+ master <- getYesod+ mapM_ (flip apLogin tp) (authPlugins master)+++loginErrorMessageI+ :: Route Auth+ -> AuthMessage+ -> AuthHandler master TypedContent+loginErrorMessageI dest msg = do+ toParent <- getRouteToParent+ loginErrorMessageMasterI (toParent dest) msg+++loginErrorMessageMasterI+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)+ => Route master+ -> AuthMessage+ -> m TypedContent+loginErrorMessageMasterI dest msg = do+ mr <- getMessageRender+ loginErrorMessage dest (mr msg)++-- | For HTML, set the message and redirect to the route.+-- For JSON, send the message and a 401 status+loginErrorMessage+ :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Route (HandlerSite m)+ -> Text+ -> m TypedContent+loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)++messageJson401+ :: MonadHandler m+ => Text+ -> m Html+ -> m TypedContent+messageJson401 = messageJsonStatus unauthorized401++messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent+messageJson500 = messageJsonStatus internalServerError500++messageJsonStatus+ :: MonadHandler m+ => Status+ -> Text+ -> m Html+ -> m TypedContent+messageJsonStatus status msg html = selectRep $ do+ provideRep html+ provideRep $ do+ let obj = object ["message" .= msg]+ void $ sendResponseStatus status obj+ return obj++provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()+provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]+++setCredsRedirect+ :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Creds (HandlerSite m) -- ^ new credentials+ -> m TypedContent+setCredsRedirect creds = do y <- getYesod- maid <- getAuthId creds- case maid of- Nothing ->- when doRedirects $ do- case authRoute y of- Nothing -> do rh <- defaultLayout $ toWidget [shamlet|-$newline never-<h1>Invalid login-|]- sendResponse rh- Just ar -> do setMessageI Msg.InvalidLogin- redirect ar- Just aid -> do+ auth <- authenticate creds+ case auth of+ Authenticated aid -> do setSession credsKey $ toPathPiece aid- when doRedirects $ do- onLogin- redirectUltDest $ loginDest y+ onLogin+ res <- selectRep $ do+ provideRepType typeHtml $+ fmap asHtml $ redirectUltDest $ loginDest y+ provideJsonMessage "Login Successful"+ sendResponse res + UserError msg ->+ case authRoute y of+ Nothing -> do+ msg' <- renderMessage' msg+ messageJson401 msg' $ authLayout $ -- TODO+ toWidget [whamlet|<h1>_{msg}|]+ Just ar -> loginErrorMessageMasterI ar msg++ ServerError msg -> do+ $(logError) msg++ case authRoute y of+ Nothing -> do+ msg' <- renderMessage' Msg.AuthError+ messageJson500 msg' $ authLayout $+ toWidget [whamlet|<h1>_{Msg.AuthError}|]+ Just ar -> loginErrorMessageMasterI ar Msg.AuthError++ where+ renderMessage' msg = do+ langs <- languages+ master <- getYesod+ return $ renderAuthMessage master langs msg++-- | Sets user credentials for the session after checking them with authentication backends.+setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Bool -- ^ if HTTP redirects should be done+ -> Creds (HandlerSite m) -- ^ new credentials+ -> m ()+setCreds doRedirects creds =+ if doRedirects+ then void $ setCredsRedirect creds+ else do auth <- authenticate creds+ case auth of+ Authenticated aid -> setSession credsKey $ toPathPiece aid+ _ -> return ()++-- | same as defaultLayoutJson, but uses authLayout+authLayoutJson+ :: (ToJSON j, MonadAuthHandler master m)+ => WidgetFor master () -- ^ HTML+ -> m j -- ^ JSON+ -> m TypedContent+authLayoutJson w json = selectRep $ do+ provideRep $ authLayout w+ provideRep $ fmap toJSON json+ -- | Clears current user credentials for the session. ----- Since 1.1.7-clearCreds :: YesodAuth master- => Bool -- ^ if HTTP redirect to 'logoutDest' should be done- -> GHandler sub master ()+-- @since 1.1.7+clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Bool -- ^ if HTTP, redirect to 'logoutDest'+ -> m () clearCreds doRedirects = do- y <- getYesod+ onLogout deleteSession credsKey- when doRedirects $ do- onLogout- redirectUltDest $ logoutDest y+ y <- getYesod+ aj <- acceptsJson+ case (aj, doRedirects) of+ (True, _) -> sendResponse successfulLogout+ (False, True) -> redirectUltDest (logoutDest y)+ _ -> return ()+ where successfulLogout = object ["message" .= msg]+ msg :: Text+ msg = "Logged out successfully!" -getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson+getCheckR :: AuthHandler master TypedContent getCheckR = do creds <- maybeAuthId- defaultLayoutJson (do+ authLayoutJson (do setTitle "Authentication Status"- toWidget $ html' creds) (jsonCreds creds)+ toWidget $ html' creds) (return $ jsonCreds creds) where html' creds = [shamlet|@@ -219,27 +454,27 @@ <p>Not logged in. |] jsonCreds creds =- Object $ Map.fromList+ toJSON $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] -setUltDestReferer' :: YesodAuth master => GHandler sub master ()+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m () setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer -getLoginR :: YesodAuth master => GHandler Auth master RepHtml+getLoginR :: AuthHandler master Html getLoginR = setUltDestReferer' >> loginHandler -getLogoutR :: YesodAuth master => GHandler Auth master ()+getLogoutR :: AuthHandler master () getLogoutR = do- tm <- getRouteToMaster- setUltDestReferer' >> redirectToPost (tm LogoutR)+ tp <- getRouteToParent+ setUltDestReferer' >> redirectToPost (tp LogoutR) -postLogoutR :: YesodAuth master => GHandler Auth master ()+postLogoutR :: AuthHandler master () postLogoutR = clearCreds True -handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master ()+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do master <- getYesod env <- waiRequest@@ -248,49 +483,122 @@ [] -> notFound ap:_ -> apDispatch ap method pieces -maybeAuth :: ( YesodAuth master-#if MIN_VERSION_persistent(1, 1, 0)- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val- , b ~ YesodPersistBackend master+-- | Similar to 'maybeAuthId', but additionally look up the value associated+-- with the user\'s database identifier to get the value in the database. This+-- assumes that you are using a Persistent database.+--+-- @since 1.1.0+maybeAuth :: ( YesodAuthPersist master+ , val ~ AuthEntity master , Key val ~ AuthId master- , PersistStore (b (GHandler sub master))-#else- , b ~ YesodPersistBackend master- , b ~ PersistEntityBackend val- , Key b val ~ AuthId master- , PersistStore b (GHandler sub master)-#endif , PersistEntity val- , YesodPersist master- ) => GHandler sub master (Maybe (Entity val))-maybeAuth = runMaybeT $ do- aid <- MaybeT $ maybeAuthId- a <- MaybeT $ runDB $ get aid- return $ Entity aid a+ , Typeable val+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Maybe (Entity val))+maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair -requireAuthId :: YesodAuth master => GHandler sub master (AuthId master)-requireAuthId = maybeAuthId >>= maybe redirectLogin return+-- | Similar to 'maybeAuth', but doesn’t assume that you are using a+-- Persistent database.+--+-- @since 1.4.0+maybeAuthPair+ :: ( YesodAuthPersist master+ , Typeable (AuthEntity master)+ , MonadHandler m+ , HandlerSite m ~ master+ )+ => m (Maybe (AuthId master, AuthEntity master))+maybeAuthPair = runMaybeT $ do+ aid <- MaybeT maybeAuthId+ ae <- MaybeT $ cachedAuth aid+ return (aid, ae) -requireAuth :: ( YesodAuth master- , b ~ YesodPersistBackend master-#if MIN_VERSION_persistent(1, 1, 0)- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val++newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }++-- | Class which states that the given site is an instance of @YesodAuth@+-- and that its @AuthId@ is a lookup key for the full user information in+-- a @YesodPersist@ database.+--+-- The default implementation of @getAuthEntity@ assumes that the @AuthId@+-- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the+-- given value. This is the common case in Yesod, and means that you can+-- easily look up the full information on a given user.+--+-- @since 1.4.0+class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where+ -- | If the @AuthId@ for a given site is a persistent ID, this will give the+ -- value for that entity. E.g.:+ --+ -- > type AuthId MySite = UserId+ -- > AuthEntity MySite ~ User+ --+ -- @since 1.2.0+ type AuthEntity master :: Type+ type AuthEntity master = KeyEntity (AuthId master)++ getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)+ => AuthId master -> m (Maybe (AuthEntity master))++ default getAuthEntity+ :: ( YesodPersistBackend master ~ backend+ , PersistRecordBackend (AuthEntity master) backend+ , Key (AuthEntity master) ~ AuthId master+ , PersistStore backend+ , MonadHandler m+ , HandlerSite m ~ master+ )+ => AuthId master -> m (Maybe (AuthEntity master))+ getAuthEntity = liftHandler . runDB . get+++type family KeyEntity key+type instance KeyEntity (Key x) = x++-- | Similar to 'maybeAuthId', but redirects to a login page if user is not+-- authenticated or responds with error 401 if this is an API client (expecting JSON).+--+-- @since 1.1.0+requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))+requireAuthId = maybeAuthId >>= maybe handleAuthLack return++-- | Similar to 'maybeAuth', but redirects to a login page if user is not+-- authenticated or responds with error 401 if this is an API client (expecting JSON).+--+-- @since 1.1.0+requireAuth :: ( YesodAuthPersist master+ , val ~ AuthEntity master , Key val ~ AuthId master- , PersistStore (b (GHandler sub master))-#else- , b ~ PersistEntityBackend val- , Key b val ~ AuthId master- , PersistStore b (GHandler sub master)-#endif , PersistEntity val- , YesodPersist master- ) => GHandler sub master (Entity val)-requireAuth = maybeAuth >>= maybe redirectLogin return+ , Typeable val+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Entity val)+requireAuth = maybeAuth >>= maybe handleAuthLack return -redirectLogin :: Yesod master => GHandler sub master a+-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.+-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.+--+-- @since 1.4.0+requireAuthPair+ :: ( YesodAuthPersist master+ , Typeable (AuthEntity master)+ , MonadHandler m+ , HandlerSite m ~ master+ )+ => m (AuthId master, AuthEntity master)+requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return++handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a+handleAuthLack = do+ aj <- acceptsJson+ if aj then notAuthenticated else redirectLogin++redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a redirectLogin = do y <- getYesod- setUltDestCurrent+ when (redirectToCurrent y) setUltDestCurrent case authRoute y of Just z -> redirect z Nothing -> permissionDenied "Please configure authRoute"@@ -298,7 +606,12 @@ instance YesodAuth master => RenderMessage master AuthMessage where renderMessage = renderAuthMessage -data AuthException = InvalidBrowserIDAssertion- | InvalidFacebookResponse- deriving (Show, Typeable)+data AuthException = InvalidFacebookResponse+ deriving Show instance Exception AuthException++instance YesodAuth master => YesodSubDispatch Auth master where+ yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)++asHtml :: Html -> Html+asHtml = id
Yesod/Auth/BrowserId.hs view
@@ -1,66 +1,91 @@-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}++-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this+-- module is no longer recommended for use. module Yesod.Auth.BrowserId+ {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-} ( authBrowserId- , authBrowserIdAudience- , createOnClick+ , createOnClick, createOnClickOverride+ , def+ , BrowserIdSettings+ , bisAudience+ , bisLazyLoad+ , forwardUrl ) where import Yesod.Auth import Web.Authenticate.BrowserId import Data.Text (Text) import Yesod.Core-import Text.Hamlet (hamlet) import qualified Data.Text as T import Data.Maybe (fromMaybe)-import Control.Monad.IO.Class (liftIO)-import Control.Monad (when)-import Control.Exception (throwIO)-import Text.Julius (julius, rawJS)-import Data.Aeson (toJSON)+import Control.Monad (when, unless)+import Text.Julius (rawJS) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) import Data.ByteString (ByteString)+import Data.Default pid :: Text pid = "browserid" -complete :: Route Auth-complete = PluginR pid []+forwardUrl :: AuthRoute+forwardUrl = PluginR pid [] --- | Log into browser ID with an audience value determined from the 'approot'.-authBrowserId :: YesodAuth m => AuthPlugin m-authBrowserId = helper Nothing+complete :: AuthRoute+complete = forwardUrl --- | Log into browser ID with the given audience value. Note that this must be--- your actual hostname, or login will fail.-authBrowserIdAudience- :: YesodAuth m- => Text -- ^ audience- -> AuthPlugin m-authBrowserIdAudience = helper . Just+-- | A settings type for various configuration options relevant to BrowserID.+--+-- See: <http://www.yesodweb.com/book/settings-types>+--+-- Since 1.2.0+data BrowserIdSettings = BrowserIdSettings+ { bisAudience :: Maybe Text+ -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the+ -- approot.+ --+ -- Default: @Nothing@+ --+ -- Since 1.2.0+ , bisLazyLoad :: Bool+ -- ^ Use asynchronous Javascript loading for the BrowserID JS file.+ --+ -- Default: @True@.+ --+ -- Since 1.2.0+ } -helper :: YesodAuth m- => Maybe Text -- ^ audience- -> AuthPlugin m-helper maudience = AuthPlugin+instance Default BrowserIdSettings where+ def = BrowserIdSettings+ { bisAudience = Nothing+ , bisLazyLoad = True+ }++authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m+authBrowserId bis@BrowserIdSettings {..} = AuthPlugin { apName = pid , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do- master <- getYesod audience <-- case maudience of+ case bisAudience of Just a -> return a Nothing -> do- tm <- getRouteToMaster r <- getUrlRender+ tm <- getRouteToParent return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR- memail <- lift $ checkAssertion audience assertion (authHttpManager master)+ manager <- authHttpManager+ memail <- checkAssertion audience assertion manager case memail of- Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion- Just email -> setCreds True Creds+ Nothing -> do+ $logErrorS "yesod-auth" "BrowserID assertion failure"+ tm <- getRouteToParent+ loginErrorMessage (tm LoginR) "BrowserID login error."+ Just email -> setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = []@@ -72,12 +97,10 @@ (_, []) -> badMethod _ -> notFound , apLogin = \toMaster -> do- onclick <- createOnClick toMaster+ onclick <- createOnClick bis toMaster - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin"- when autologin $ toWidget [julius|-#{rawJS onclick}();-|]+ autologin <- fmap (== Just "true") $ lookupGetParam "autologin"+ when autologin $ toWidget [julius|#{rawJS onclick}();|] toWidget [hamlet| $newline never@@ -92,32 +115,57 @@ -- | Generates a function to handle on-click events, and returns that function -- name.-createOnClick :: (Route Auth -> Route master) -> GWidget sub master Text-createOnClick toMaster = do- addScriptRemote browserIdJs- onclick <- lift newIdent- render <- lift getUrlRender- let login = toJSON $ getPath $ render (toMaster LoginR)+createOnClickOverride :: BrowserIdSettings+ -> (Route Auth -> Route master)+ -> Maybe (Route master)+ -> WidgetFor master Text+createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do+ unless bisLazyLoad $ addScriptRemote browserIdJs+ onclick <- newIdent+ render <- getUrlRender+ let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)+ loginRoute = maybe (toMaster LoginR) id mOnRegistration toWidget [julius| function #{rawJS onclick}() {- navigator.id.watch({- onlogin: function (assertion) {- if (assertion) {- document.location = "@{toMaster complete}/" + assertion;- }- },- onlogout: function () {}- });- navigator.id.request({- returnTo: #{login} + "?autologin=true"- });+ if (navigator.id) {+ navigator.id.watch({+ onlogin: function (assertion) {+ if (assertion) {+ document.location = "@{toMaster complete}/" + assertion;+ }+ },+ onlogout: function () {}+ });+ navigator.id.request({+ returnTo: #{login} + "?autologin=true"+ });+ }+ else {+ alert("Loading, please try again");+ } } |]+ when bisLazyLoad $ toWidget [julius|+ (function(){+ var bid = document.createElement("script");+ bid.async = true;+ bid.src = #{toJSON browserIdJs};+ var s = document.getElementsByTagName('script')[0];+ s.parentNode.insertBefore(bid, s);+ })();+ |] - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin"+ autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius|#{rawJS onclick}();|] return onclick where getPath t = fromMaybe t $ do uri <- parseURI $ T.unpack t return $ T.pack $ uriPath uri++-- | Generates a function to handle on-click events, and returns that function+-- name.+createOnClick :: BrowserIdSettings+ -> (Route Auth -> Route master)+ -> WidgetFor master Text+createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing
Yesod/Auth/Dummy.hs view
@@ -1,31 +1,77 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | Provides a dummy authentication module that simply lets a user specify--- his/her identifier. This is not intended for real world use, just for--- testing.+-- their identifier. This is not intended for real world use, just for+-- testing. This plugin supports form submissions via JSON (since 1.6.8).+--+-- = Using the JSON Login Endpoint+--+-- We are assuming that you have declared `authRoute` as follows+--+-- @+-- Just $ AuthR LoginR+-- @+--+-- If you are using a different one, then you have to adjust the+-- endpoint accordingly.+--+-- @+-- Endpoint: \/auth\/page\/dummy+-- Method: POST+-- JSON Data: {+-- "ident": "my identifier"+-- }+-- @+--+-- Remember to add the following headers:+--+-- - Accept: application\/json+-- - Content-Type: application\/json+ module Yesod.Auth.Dummy ( authDummy ) where -import Yesod.Auth-import Yesod.Form (runInputPost, textField, ireq)-import Yesod.Handler (notFound)-import Text.Hamlet (hamlet)-import Yesod.Widget (toWidget)+import Data.Aeson.Types (Parser, Result (..))+import qualified Data.Aeson.Types as A (parseEither, withObject)+import Data.Text (Text)+import Yesod.Auth+import Yesod.Core+import Yesod.Form (ireq, runInputPost, textField) +identParser :: Value -> Parser Text+identParser = A.withObject "Ident" (.: "ident")+ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where+ dispatch :: Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" [] = do- ident <- runInputPost $ ireq textField "ident"- setCreds True $ Creds "dummy" ident []+ (jsonResult :: Result Value) <- parseCheckJsonBody+ eIdent <- case jsonResult of+ Success val -> return $ A.parseEither identParser val+ Error err -> return $ Left err+ case eIdent of+ Right ident ->+ setCredsRedirect $ Creds "dummy" ident []+ Left _ -> do+ ident <- runInputPost $ ireq textField "ident"+ setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" []- login authToMaster =+ login authToMaster = do+ request <- getRequest toWidget [hamlet| $newline never <form method="post" action="@{authToMaster url}">+ $maybe t <- reqToken request+ <input type=hidden name=#{defaultCsrfParamName} value=#{t}> Your new identifier is: # <input type="text" name="ident"> <input type="submit" value="Dummy Login">
Yesod/Auth/Email.hs view
@@ -1,283 +1,999 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Auth.Email- ( -- * Plugin- authEmail- , YesodAuthEmail (..)- , EmailCreds (..)- , saltPass- -- * Routes- , loginR- , registerR- , setpassR- , isValidPass- ) where--import Network.Mail.Mime (randomString)-import Yesod.Auth-import System.Random-import Control.Monad (when)-import Control.Applicative ((<$>), (<*>))-import Data.Digest.Pure.MD5-import qualified Data.Text.Lazy as T-import qualified Data.Text as TS-import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Text (Text)-import qualified Crypto.PasswordStore as PS-import qualified Data.Text.Encoding as DTE--import Yesod.Form-import Yesod.Handler-import Yesod.Content-import Yesod.Core (PathPiece, fromPathPiece, whamlet, defaultLayout, setTitleI, toPathPiece)-import Control.Monad.IO.Class (liftIO)-import qualified Yesod.Auth.Message as Msg--loginR, registerR, setpassR :: AuthRoute-loginR = PluginR "email" ["login"]-registerR = PluginR "email" ["register"]-setpassR = PluginR "email" ["set-password"]--verify :: Text -> Text -> AuthRoute -- FIXME-verify eid verkey = PluginR "email" ["verify", eid, verkey]--type Email = Text-type VerKey = Text-type VerUrl = Text-type SaltedPass = Text-type VerStatus = Bool---- | Data stored in a database for each e-mail address.-data EmailCreds m = EmailCreds- { emailCredsId :: AuthEmailId m- , emailCredsAuthId :: Maybe (AuthId m)- , emailCredsStatus :: VerStatus- , emailCredsVerkey :: Maybe VerKey- }--class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where- type AuthEmailId m-- addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)- sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()- getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)- setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()- verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))- getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)- setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()- getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))- getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)-- -- | Generate a random alphanumeric string.- randomKey :: m -> IO Text- randomKey _ = do- stdgen <- newStdGen- return $ TS.pack $ fst $ randomString 10 stdgen--authEmail :: YesodAuthEmail m => AuthPlugin m-authEmail =- AuthPlugin "email" dispatch $ \tm ->- [whamlet|-$newline never-<form method="post" action="@{tm loginR}">- <table>- <tr>- <th>_{Msg.Email}- <td>- <input type="email" name="email">- <tr>- <th>_{Msg.Password}- <td>- <input type="password" name="password">- <tr>- <td colspan="2">- <input type="submit" value=_{Msg.LoginViaEmail}>- <a href="@{tm registerR}">I don't have an account-|]- where- dispatch "GET" ["register"] = getRegisterR >>= sendResponse- dispatch "POST" ["register"] = postRegisterR >>= sendResponse- dispatch "GET" ["verify", eid, verkey] =- case fromPathPiece eid of- Nothing -> notFound- Just eid' -> getVerifyR eid' verkey >>= sendResponse- dispatch "POST" ["login"] = postLoginR >>= sendResponse- dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse- dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse- dispatch _ _ = notFound--getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml-getRegisterR = do- toMaster <- getRouteToMaster- email <- newIdent- defaultLayout $ do- setTitleI Msg.RegisterLong- [whamlet|-$newline never-<p>_{Msg.EnterEmail}-<form method="post" action="@{toMaster registerR}">- <label for=#{email}>_{Msg.Email}- <input ##{email} type="email" name="email" width="150">- <input type="submit" value=_{Msg.Register}>-|]--postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml-postRegisterR = do- y <- getYesod- email <- runInputPost $ ireq emailField "email"- mecreds <- getEmailCreds email- (lid, verKey) <-- case mecreds of- Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)- Just (EmailCreds lid _ _ Nothing) -> do- key <- liftIO $ randomKey y- setVerifyKey lid key- return (lid, key)- Nothing -> do- key <- liftIO $ randomKey y- lid <- addUnverified email key- return (lid, key)- render <- getUrlRender- tm <- getRouteToMaster- let verUrl = render $ tm $ verify (toPathPiece lid) verKey- sendVerifyEmail email verKey verUrl- defaultLayout $ do- setTitleI Msg.ConfirmationEmailSentTitle- [whamlet|-$newline never-<p>_{Msg.ConfirmationEmailSent email}-|]--getVerifyR :: YesodAuthEmail m- => AuthEmailId m -> Text -> GHandler Auth m RepHtml-getVerifyR lid key = do- realKey <- getVerifyKey lid- memail <- getEmail lid- case (realKey == Just key, memail) of- (True, Just email) -> do- muid <- verifyAccount lid- case muid of- Nothing -> return ()- Just _uid -> do- setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?- toMaster <- getRouteToMaster- setMessageI Msg.AddressVerified- redirect $ toMaster setpassR- _ -> return ()- defaultLayout $ do- setTitleI Msg.InvalidKey- [whamlet|-$newline never-<p>_{Msg.InvalidKey}-|]--postLoginR :: YesodAuthEmail master => GHandler Auth master ()-postLoginR = do- (email, pass) <- runInputPost $ (,)- <$> ireq emailField "email"- <*> ireq textField "password"- mecreds <- getEmailCreds email- maid <-- case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of- (Just aid, Just True) -> do- mrealpass <- getPassword aid- case mrealpass of- Nothing -> return Nothing- Just realpass -> return $- if isValidPass pass realpass- then Just aid- else Nothing- _ -> return Nothing- case maid of- Just _aid ->- setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?- Nothing -> do- setMessageI Msg.InvalidEmailPass- toMaster <- getRouteToMaster- redirect $ toMaster LoginR--getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml-getPasswordR = do- toMaster <- getRouteToMaster- maid <- maybeAuthId- pass1 <- newIdent- pass2 <- newIdent- case maid of- Just _ -> return ()- Nothing -> do- setMessageI Msg.BadSetPass- redirect $ toMaster LoginR- defaultLayout $ do- setTitleI Msg.SetPassTitle- [whamlet|-$newline never-<h3>_{Msg.SetPass}-<form method="post" action="@{toMaster setpassR}">- <table>- <tr>- <th>- <label for=#{pass1}>_{Msg.NewPass}- <td>- <input ##{pass1} type="password" name="new">- <tr>- <th>- <label for=#{pass2}>_{Msg.ConfirmPass}- <td>- <input ##{pass2} type="password" name="confirm">- <tr>- <td colspan="2">- <input type="submit" value="_{Msg.SetPassTitle}">-|]--postPasswordR :: YesodAuthEmail master => GHandler Auth master ()-postPasswordR = do- (new, confirm) <- runInputPost $ (,)- <$> ireq textField "new"- <*> ireq textField "confirm"- toMaster <- getRouteToMaster- y <- getYesod- when (new /= confirm) $ do- setMessageI Msg.PassMismatch- redirect $ toMaster setpassR- maid <- maybeAuthId- aid <- case maid of- Nothing -> do- setMessageI Msg.BadSetPass- redirect $ toMaster LoginR- Just aid -> return aid- salted <- liftIO $ saltPass new- setPassword aid salted- setMessageI Msg.PassUpdated- redirect $ loginDest y--saltLength :: Int-saltLength = 5---- | Salt a password with a randomly generated salt.-saltPass :: Text -> IO Text-saltPass = fmap DTE.decodeUtf8- . flip PS.makePassword 12- . DTE.encodeUtf8--saltPass' :: String -> String -> String-saltPass' salt pass =- salt ++ show (md5 $ fromString $ salt ++ pass)- where- fromString = encodeUtf8 . T.pack--isValidPass :: Text -- ^ cleartext password- -> SaltedPass -- ^ salted password- -> Bool-isValidPass ct salted =- PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted--isValidPass' :: Text -- ^ cleartext password- -> SaltedPass -- ^ salted password- -> Bool-isValidPass' clear' salted' =- let salt = take saltLength salted- in salted == saltPass' salt clear- where- clear = TS.unpack clear'- salted = TS.unpack salted'+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | A Yesod plugin for Authentication via e-mail+--+-- This plugin works out of the box by only setting a few methods on+-- the type class that tell the plugin how to interoperate with your+-- user data storage (your database). However, almost everything is+-- customizeable by setting more methods on the type class. In+-- addition, you can send all the form submissions via JSON and+-- completely control the user's flow.+--+-- This is a standard registration e-mail flow+--+-- 1. A user registers a new e-mail address, and an e-mail is sent there+-- 2. The user clicks on the registration link in the e-mail. Note that+-- at this point they are actually logged in (without a+-- password). That means that when they log out they will need to+-- reset their password.+-- 3. The user sets their password and is redirected to the site.+-- 4. The user can now+--+-- * logout and sign in+-- * reset their password+--+-- = Using JSON Endpoints+--+-- We are assuming that you have declared auth route as follows+--+-- @+-- /auth AuthR Auth getAuth+-- @+--+-- If you are using a different route, then you have to adjust the+-- endpoints accordingly.+--+-- * Registration+--+-- @+-- Endpoint: \/auth\/page\/email\/register+-- Method: POST+-- JSON Data: {+-- "email": "myemail@domain.com",+-- "password": "myStrongPassword" (optional)+-- }+-- @+--+-- * Forgot password+--+-- @+-- Endpoint: \/auth\/page\/email\/forgot-password+-- Method: POST+-- JSON Data: { "email": "myemail@domain.com" }+-- @+--+-- * Login+--+-- @+-- Endpoint: \/auth\/page\/email\/login+-- Method: POST+-- JSON Data: {+-- "email": "myemail@domain.com",+-- "password": "myStrongPassword"+-- }+-- @+--+-- * Set new password+--+-- @+-- Endpoint: \/auth\/page\/email\/set-password+-- Method: POST+-- JSON Data: {+-- "new": "newPassword",+-- "confirm": "newPassword",+-- "current": "currentPassword"+-- }+-- @+--+-- Note that in the set password endpoint, the presence of the key+-- "current" is dependent on how the 'needOldPassword' is defined in+-- the instance for 'YesodAuthEmail'.++module Yesod.Auth.Email+ ( -- * Plugin+ authEmail+ , YesodAuthEmail (..)+ , EmailCreds (..)+ , saltPass+ -- * Routes+ , loginR+ , registerR+ , forgotPasswordR+ , setpassR+ , verifyR+ , isValidPass+ -- * Types+ , Email+ , VerKey+ , VerUrl+ , SaltedPass+ , VerStatus+ , Identifier+ -- * Misc+ , loginLinkKey+ , setLoginLinkKey+ -- * Default handlers+ , defaultEmailLoginHandler+ , defaultRegisterHandler+ , defaultForgotPasswordHandler+ , defaultSetPasswordHandler+ -- * Default helpers+ , defaultRegisterHelper+ ) where++import qualified Crypto.Hash as H+import qualified Crypto.Nonce as Nonce+import Data.Aeson.Types (Parser, Result (..), parseMaybe,+ withObject, (.:?))+import Data.ByteArray (convert)+import Data.ByteString.Base16 as B16+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text as TS+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time (addUTCTime, getCurrentTime)+import Safe (readMay)+import System.IO.Unsafe (unsafePerformIO)+import qualified Text.Email.Validate+import Yesod.Auth+import qualified Yesod.Auth.Message as Msg+import qualified Yesod.Auth.Util.PasswordStore as PS+import Yesod.Core+import Yesod.Form++loginR, registerR, forgotPasswordR, setpassR :: AuthRoute+loginR = PluginR "email" ["login"]+registerR = PluginR "email" ["register"]+forgotPasswordR = PluginR "email" ["forgot-password"]+setpassR = PluginR "email" ["set-password"]++verifyURLHasSetPassText :: Text+verifyURLHasSetPassText = "has-set-pass"++-- |+--+-- @since 1.4.5+verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME+verifyR eid verkey hasSetPass = PluginR "email" path+ where path = "verify":eid:verkey:(if hasSetPass then [verifyURLHasSetPassText] else [])++type Email = Text+type VerKey = Text+type VerUrl = Text+type SaltedPass = Text+type VerStatus = Bool++-- | An Identifier generalizes an email address to allow users to log in with+-- some other form of credentials (e.g., username).+--+-- Note that any of these other identifiers must not be valid email addresses.+--+-- @since 1.2.0+type Identifier = Text++-- | Data stored in a database for each e-mail address.+data EmailCreds site = EmailCreds+ { emailCredsId :: AuthEmailId site+ , emailCredsAuthId :: Maybe (AuthId site)+ , emailCredsStatus :: VerStatus+ , emailCredsVerkey :: Maybe VerKey+ , emailCredsEmail :: Email+ }++data ForgotPasswordForm = ForgotPasswordForm { _forgotEmail :: Text }+data PasswordForm = PasswordForm { _passwordCurrent :: Text, _passwordNew :: Text, _passwordConfirm :: Text }+data UserForm = UserForm { _userFormEmail :: Text }+data UserLoginForm = UserLoginForm { _loginEmail :: Text, _loginPassword :: Text }++class ( YesodAuth site+ , PathPiece (AuthEmailId site)+ , (RenderMessage site Msg.AuthMessage)+ )+ => YesodAuthEmail site where+ type AuthEmailId site++ -- | Add a new email address to the database, but indicate that the address+ -- has not yet been verified.+ --+ -- @since 1.1.0+ addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)++ -- | Similar to `addUnverified`, but comes with the registered password.+ --+ -- The default implementation is just `addUnverified`, which ignores the password.+ --+ -- You may override this to save the salted password to your database.+ --+ -- @since 1.6.4+ addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site)+ addUnverifiedWithPass email verkey _ = addUnverified email verkey++ -- | Send an email to the given address to verify ownership.+ --+ -- @since 1.1.0+ sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()++ -- | Send an email to the given address to re-verify ownership in the case of+ -- a password reset. This can be used to send a different email when a user+ -- goes through the 'forgot password' flow as opposed to the 'account registration'+ -- flow.+ --+ -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent+ -- for both registrations and password resets.+ --+ -- @since 1.6.10+ sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()+ sendForgotPasswordEmail = sendVerifyEmail++ -- | Get the verification key for the given email ID.+ --+ -- @since 1.1.0+ getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey)++ -- | Set the verification key for the given email ID.+ --+ -- @since 1.1.0+ setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()++ -- | Hash and salt a password+ --+ -- Default: 'saltPass'.+ --+ -- @since 1.4.20+ hashAndSaltPassword :: Text -> AuthHandler site SaltedPass+ hashAndSaltPassword password = liftIO $ saltPass password++ -- | Verify a password matches the stored password for the given account.+ --+ -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.+ --+ -- @since 1.4.20+ verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool+ verifyPassword plain salted = return $ isValidPass plain salted++ -- | Verify the email address on the given account.+ --+ -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@+ -- somewhere, this method should delete that key, or make it unusable+ -- in some fashion. Otherwise, the same key can be used multiple times!+ --+ -- See <https://github.com/yesodweb/yesod/issues/1222>.+ --+ -- @since 1.1.0+ verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site))++ -- | Get the salted password for the given account.+ --+ -- @since 1.1.0+ getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass)++ -- | Set the salted password for the given account.+ --+ -- @since 1.1.0+ setPassword :: AuthId site -> SaltedPass -> AuthHandler site ()++ -- | Get the credentials for the given @Identifier@, which may be either an+ -- email address or some other identification (e.g., username).+ --+ -- @since 1.2.0+ getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site))++ -- | Get the email address for the given email ID.+ --+ -- @since 1.1.0+ getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)++ -- | Generate a random alphanumeric string.+ --+ -- @since 1.1.0+ randomKey :: site -> IO VerKey+ randomKey _ = Nonce.nonce128urlT defaultNonceGen++ -- | Route to send user to after password has been set correctly.+ --+ -- @since 1.2.0+ afterPasswordRoute :: site -> Route site++ -- | Same as @afterPasswordRoute@ but allows you to run Handler code+ --+ -- If this function is overridden then @afterPasswordRoute@ is ignored.+ --+ -- @since 1.6.12.0+ afterPasswordRouteHandler :: AuthHandler site (Route site)+ afterPasswordRouteHandler = getYesod >>= pure . afterPasswordRoute++ -- | Route to send user to after verification with a password+ --+ -- @since 1.6.4+ afterVerificationWithPass :: site -> Route site+ afterVerificationWithPass = afterPasswordRoute++ -- | Does the user need to provide the current password in order to set a+ -- new password?+ --+ -- Default: if the user logged in via an email link do not require a password.+ --+ -- @since 1.2.1+ needOldPassword :: AuthId site -> AuthHandler site Bool+ needOldPassword aid' = do+ mkey <- lookupSession loginLinkKey+ case mkey >>= readMay . TS.unpack of+ Just (aidT, time) | Just aid <- fromPathPiece aidT, toPathPiece (aid `asTypeOf` aid') == toPathPiece aid' -> do+ now <- liftIO getCurrentTime+ return $ addUTCTime (60 * 30) time <= now+ _ -> return True++ -- | Check that the given plain-text password meets minimum security standards.+ --+ -- Default: password is at least three characters.+ checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ())+ checkPasswordSecurity _ x+ | TS.length x >= 3 = return $ Right ()+ | otherwise = return $ Left "Password must be at least three characters"++ -- | Response after sending a confirmation email.+ --+ -- @since 1.2.2+ confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent+ confirmationEmailSentResponse identifier = do+ mr <- getMessageRender+ selectRep $ do+ provideJsonMessage (mr msg)+ provideRep $ authLayout $ do+ setTitleI Msg.ConfirmationEmailSentTitle+ [whamlet|<p>_{msg}|]+ where+ msg = Msg.ConfirmationEmailSent identifier++ -- | If a response is set, it will be used when an already-verified email+ -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be+ -- used.+ --+ -- @since 1.6.4+ emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)+ emailPreviouslyRegisteredResponse _ = Nothing++ -- | Additional normalization of email addresses, besides standard canonicalization.+ --+ -- Default: Lower case the email address.+ --+ -- @since 1.2.3+ normalizeEmailAddress :: site -> Text -> Text+ normalizeEmailAddress _ = TS.toLower++ -- | Handler called to render the login page.+ -- The default works fine, but you may want to override it in+ -- order to have a different DOM.+ --+ -- Default: 'defaultEmailLoginHandler'.+ --+ -- @since 1.4.17+ emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()+ emailLoginHandler = defaultEmailLoginHandler+++ -- | Handler called to render the registration page. The+ -- default works fine, but you may want to override it in+ -- order to have a different DOM.+ --+ -- Default: 'defaultRegisterHandler'.+ --+ -- @since: 1.2.6+ registerHandler :: AuthHandler site Html+ registerHandler = defaultRegisterHandler++ -- | Handler called to render the \"forgot password\" page.+ -- The default works fine, but you may want to override it in+ -- order to have a different DOM.+ --+ -- Default: 'defaultForgotPasswordHandler'.+ --+ -- @since: 1.2.6+ forgotPasswordHandler :: AuthHandler site Html+ forgotPasswordHandler = defaultForgotPasswordHandler++ -- | Handler called to render the \"set password\" page. The+ -- default works fine, but you may want to override it in+ -- order to have a different DOM.+ --+ -- Default: 'defaultSetPasswordHandler'.+ --+ -- @since: 1.2.6+ setPasswordHandler ::+ Bool+ -- ^ Whether the old password is needed. If @True@, a+ -- field for the old password should be presented.+ -- Otherwise, just two fields for the new password are+ -- needed.+ -> AuthHandler site TypedContent+ setPasswordHandler = defaultSetPasswordHandler+++ -- | Helper that controls what happens after a user registration+ -- request is submitted. This method can be overridden to completely+ -- customize what happens during the user registration process,+ -- such as for handling additional fields in the registration form.+ --+ -- The default implementation is in terms of 'defaultRegisterHelper'.+ --+ -- @since: 1.6.9+ registerHelper :: Route Auth+ -- ^ Where to sent the user in the event+ -- that registration fails+ -> AuthHandler site TypedContent+ registerHelper = defaultRegisterHelper False False++ -- | Helper that controls what happens after a forgot password+ -- request is submitted. As with `registerHelper`, this method can+ -- be overridden to customize the behavior when a user attempts+ -- to recover their password.+ --+ -- The default implementation is in terms of 'defaultRegisterHelper'.+ --+ -- @since: 1.6.9+ passwordResetHelper :: Route Auth+ -- ^ Where to sent the user in the event+ -- that the password reset fails+ -> AuthHandler site TypedContent+ passwordResetHelper = defaultRegisterHelper True True++authEmail :: (YesodAuthEmail m) => AuthPlugin m+authEmail =+ AuthPlugin "email" dispatch emailLoginHandler+ where+ dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent+ dispatch "GET" ["register"] = getRegisterR >>= sendResponse+ dispatch "POST" ["register"] = postRegisterR >>= sendResponse+ dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse+ dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse+ dispatch "GET" ["verify", eid, verkey] =+ case fromPathPiece eid of+ Nothing -> notFound+ Just eid' -> getVerifyR eid' verkey False >>= sendResponse+ dispatch "GET" ["verify", eid, verkey, hasSetPass] =+ case fromPathPiece eid of+ Nothing -> notFound+ Just eid' -> getVerifyR eid' verkey (hasSetPass == verifyURLHasSetPassText) >>= sendResponse+ dispatch "POST" ["login"] = postLoginR >>= sendResponse+ dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse+ dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse+ dispatch _ _ = notFound++getRegisterR :: YesodAuthEmail master => AuthHandler master Html+getRegisterR = registerHandler++-- | Default implementation of 'emailLoginHandler'.+--+-- @since 1.4.17+defaultEmailLoginHandler+ :: YesodAuthEmail master+ => (Route Auth -> Route master)+ -> WidgetFor master ()+defaultEmailLoginHandler toParent = do+ (widget, enctype) <- generateFormPost loginForm++ [whamlet|+ <form method="post" action="@{toParent loginR}" enctype=#{enctype}>+ <div id="emailLoginForm">+ ^{widget}+ <div>+ <button type=submit .btn .btn-success>+ _{Msg.LoginViaEmail}+ + <a href="@{toParent registerR}" .btn .btn-default>+ _{Msg.RegisterLong}+ |]+ where+ loginForm extra = do++ emailMsg <- renderMessage' Msg.Email+ (emailRes, emailView) <- mreq emailField (emailSettings emailMsg) Nothing++ passwordMsg <- renderMessage' Msg.Password+ (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing++ let userRes = UserLoginForm <$> emailRes <*> passwordRes+ let widget = do+ [whamlet|+ #{extra}+ <div>+ ^{fvInput emailView}+ <div>+ ^{fvInput passwordView}+ |]++ return (userRes, widget)+ emailSettings emailMsg = do+ FieldSettings {+ fsLabel = SomeMessage Msg.Email,+ fsTooltip = Nothing,+ fsId = Just "email",+ fsName = Just "email",+ fsAttrs = [("autofocus", ""), ("placeholder", emailMsg)]+ }+ passwordSettings passwordMsg =+ FieldSettings {+ fsLabel = SomeMessage Msg.Password,+ fsTooltip = Nothing,+ fsId = Just "password",+ fsName = Just "password",+ fsAttrs = [("placeholder", passwordMsg)]+ }+ renderMessage' msg = do+ langs <- languages+ master <- getYesod+ return $ renderAuthMessage master langs msg++-- | Default implementation of 'registerHandler'.+--+-- @since 1.2.6+defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html+defaultRegisterHandler = do+ (widget, enctype) <- generateFormPost registrationForm+ toParentRoute <- getRouteToParent+ authLayout $ do+ setTitleI Msg.RegisterLong+ [whamlet|+ <p>_{Msg.EnterEmail}+ <form method="post" action="@{toParentRoute registerR}" enctype=#{enctype}>+ <div id="registerForm">+ ^{widget}+ <button .btn>_{Msg.Register}+ |]+ where+ registrationForm extra = do+ let emailSettings = FieldSettings {+ fsLabel = SomeMessage Msg.Email,+ fsTooltip = Nothing,+ fsId = Just "email",+ fsName = Just "email",+ fsAttrs = [("autofocus", "")]+ }++ (emailRes, emailView) <- mreq emailField emailSettings Nothing++ let userRes = UserForm <$> emailRes+ let widget = do+ [whamlet|+ #{extra}+ ^{fvLabel emailView}+ ^{fvInput emailView}+ |]++ return (userRes, widget)++parseRegister :: Value -> Parser (Text, Maybe Text)+parseRegister = withObject "email" (\obj -> do+ email <- obj .: "email"+ pass <- obj .:? "password"+ return (email, pass))++defaultRegisterHelper :: YesodAuthEmail master+ => Bool -- ^ Allow lookup via username in addition to email+ -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration+ -> Route Auth+ -> AuthHandler master TypedContent+defaultRegisterHelper allowUsername forgotPassword dest = do+ y <- getYesod+ checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName+ result <- runInputPostResult $ (,)+ <$> ireq textField "email"+ <*> iopt textField "password"++ creds <- case result of+ FormSuccess (iden, pass) -> return $ Just (iden, pass)+ _ -> do+ (creds :: Result Value) <- parseCheckJsonBody+ return $ case creds of+ Error _ -> Nothing+ Success val -> parseMaybe parseRegister val++ let eidentifier = case creds of+ Nothing -> Left Msg.NoIdentifierProvided+ Just (x, _)+ | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->+ Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'+ | allowUsername -> Right $ TS.strip x+ | otherwise -> Left Msg.InvalidEmailAddress++ let mpass = case (forgotPassword, creds) of+ (False, Just (_, mp)) -> mp+ _ -> Nothing++ case eidentifier of+ Left failMsg -> loginErrorMessageI dest failMsg+ Right identifier -> do+ mecreds <- getEmailCreds identifier+ registerCreds <-+ case mecreds of+ Just (EmailCreds lid _ verStatus (Just key) email) -> return $ Just (lid, verStatus, key, email)+ Just (EmailCreds lid _ verStatus Nothing email) -> do+ key <- liftIO $ randomKey y+ setVerifyKey lid key+ return $ Just (lid, verStatus, key, email)+ Nothing+ | allowUsername -> return Nothing+ | otherwise -> do+ key <- liftIO $ randomKey y+ lid <- case mpass of+ Just pass -> do+ salted <- hashAndSaltPassword pass+ addUnverifiedWithPass identifier key salted+ _ -> addUnverified identifier key+ return $ Just (lid, False, key, identifier)+ case registerCreds of+ Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)+ Just regCreds@(_, False, _, _) -> sendConfirmationEmail regCreds+ Just regCreds@(_, True, _, _) -> do+ if forgotPassword+ then sendConfirmationEmail regCreds+ else case emailPreviouslyRegisteredResponse identifier of+ Just response -> response+ Nothing -> sendConfirmationEmail regCreds+ where sendConfirmationEmail (lid, _, verKey, email) = do+ render <- getUrlRender+ tp <- getRouteToParent+ let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)+ if forgotPassword+ then sendForgotPasswordEmail email verKey verUrl+ else sendVerifyEmail email verKey verUrl+ confirmationEmailSentResponse identifier+++postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent+postRegisterR = registerHelper registerR++getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html+getForgotPasswordR = forgotPasswordHandler++-- | Default implementation of 'forgotPasswordHandler'.+--+-- @since 1.2.6+defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html+defaultForgotPasswordHandler = do+ (widget, enctype) <- generateFormPost forgotPasswordForm+ toParent <- getRouteToParent+ authLayout $ do+ setTitleI Msg.PasswordResetTitle+ [whamlet|+ <p>_{Msg.PasswordResetPrompt}+ <form method=post action=@{toParent forgotPasswordR} enctype=#{enctype}>+ <div id="forgotPasswordForm">+ ^{widget}+ <button .btn>_{Msg.SendPasswordResetEmail}+ |]+ where+ forgotPasswordForm extra = do+ (emailRes, emailView) <- mreq emailField emailSettings Nothing++ let forgotPasswordRes = ForgotPasswordForm <$> emailRes+ let widget = do+ [whamlet|+ #{extra}+ ^{fvLabel emailView}+ ^{fvInput emailView}+ |]+ return (forgotPasswordRes, widget)++ emailSettings =+ FieldSettings {+ fsLabel = SomeMessage Msg.ProvideIdentifier,+ fsTooltip = Nothing,+ fsId = Just "forgotPassword",+ fsName = Just "email",+ fsAttrs = [("autofocus", "")]+ }++postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent+postForgotPasswordR = passwordResetHelper forgotPasswordR++getVerifyR :: YesodAuthEmail site+ => AuthEmailId site+ -> Text+ -> Bool+ -> AuthHandler site TypedContent+getVerifyR lid key hasSetPass = do+ realKey <- getVerifyKey lid+ memail <- getEmail lid+ mr <- getMessageRender+ case (realKey == Just key, memail) of+ (True, Just email) -> do+ muid <- verifyAccount lid+ case muid of+ Nothing -> invalidKey mr+ Just uid -> do+ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?+ setLoginLinkKey uid+ let msgAv = if hasSetPass+ then Msg.EmailVerified+ else Msg.EmailVerifiedChangePass+ selectRep $ do+ provideRep $ do+ addMessageI "success" msgAv+ redirectRoute <- if hasSetPass+ then do+ y <- getYesod+ return $ afterVerificationWithPass y+ else do+ tp <- getRouteToParent+ return $ tp setpassR+ fmap asHtml $ redirect redirectRoute+ provideJsonMessage $ mr msgAv+ _ -> invalidKey mr+ where+ msgIk = Msg.InvalidKey+ invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do+ setTitleI msgIk+ [whamlet|+$newline never+<p>_{msgIk}+|]+++parseCreds :: Value -> Parser (Text, Text)+parseCreds = withObject "creds" (\obj -> do+ email' <- obj .: "email"+ pass <- obj .: "password"+ return (email', pass))+++postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent+postLoginR = do+ result <- runInputPostResult $ (,)+ <$> ireq textField "email"+ <*> ireq textField "password"++ midentifier <- case result of+ FormSuccess (iden, pass) -> return $ Just (iden, pass)+ _ -> do+ (creds :: Result Value) <- parseCheckJsonBody+ case creds of+ Error _ -> return Nothing+ Success val -> return $ parseMaybe parseCreds val++ case midentifier of+ Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided+ Just (identifier, pass) -> do+ mecreds <- getEmailCreds identifier+ maid <-+ case ( mecreds >>= emailCredsAuthId+ , emailCredsEmail <$> mecreds+ , emailCredsStatus <$> mecreds+ ) of+ (Just aid, Just email', Just True) -> do+ mrealpass <- getPassword aid+ case mrealpass of+ Nothing -> return Nothing+ Just realpass -> do+ passValid <- verifyPassword pass realpass+ return $ if passValid+ then Just email'+ else Nothing+ _ -> return Nothing+ let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier+ case maid of+ Just email' ->+ setCredsRedirect $ Creds+ (if isEmail then "email" else "username")+ email'+ [("verifiedEmail", email')]+ Nothing ->+ loginErrorMessageI LoginR $+ if isEmail+ then Msg.InvalidEmailPass+ else Msg.InvalidUsernamePass++getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent+getPasswordR = do+ maid <- maybeAuthId+ case maid of+ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass+ Just aid -> do+ needOld <- needOldPassword aid+ setPasswordHandler needOld++-- | Default implementation of 'setPasswordHandler'.+--+-- @since 1.2.6+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent+defaultSetPasswordHandler needOld = do+ messageRender <- getMessageRender+ toParent <- getRouteToParent+ selectRep $ do+ provideJsonMessage $ messageRender Msg.SetPass+ provideRep $ authLayout $ do+ (widget, enctype) <- generateFormPost setPasswordForm+ setTitleI Msg.SetPassTitle+ [whamlet|+ <h3>_{Msg.SetPass}+ <form method="post" action="@{toParent setpassR}" enctype=#{enctype}>+ ^{widget}+ |]+ where+ setPasswordForm extra = do+ (currentPasswordRes, currentPasswordView) <- mreq passwordField currentPasswordSettings Nothing+ (newPasswordRes, newPasswordView) <- mreq passwordField newPasswordSettings Nothing+ (confirmPasswordRes, confirmPasswordView) <- mreq passwordField confirmPasswordSettings Nothing++ let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes+ let widget = do+ [whamlet|+ #{extra}+ <table>+ $if needOld+ <tr>+ <th>+ ^{fvLabel currentPasswordView}+ <td>+ ^{fvInput currentPasswordView}+ <tr>+ <th>+ ^{fvLabel newPasswordView}+ <td>+ ^{fvInput newPasswordView}+ <tr>+ <th>+ ^{fvLabel confirmPasswordView}+ <td>+ ^{fvInput confirmPasswordView}+ <tr>+ <td colspan="2">+ <input type=submit value=_{Msg.SetPassTitle}>+ |]++ return (passwordFormRes, widget)+ currentPasswordSettings =+ FieldSettings {+ fsLabel = SomeMessage Msg.CurrentPassword,+ fsTooltip = Nothing,+ fsId = Just "currentPassword",+ fsName = Just "current",+ fsAttrs = [("autofocus", "")]+ }+ newPasswordSettings =+ FieldSettings {+ fsLabel = SomeMessage Msg.NewPass,+ fsTooltip = Nothing,+ fsId = Just "newPassword",+ fsName = Just "new",+ fsAttrs = [("autofocus", ""), (":not", ""), ("needOld:autofocus", "")]+ }+ confirmPasswordSettings =+ FieldSettings {+ fsLabel = SomeMessage Msg.ConfirmPass,+ fsTooltip = Nothing,+ fsId = Just "confirmPassword",+ fsName = Just "confirm",+ fsAttrs = [("autofocus", "")]+ }++parsePassword :: Value -> Parser (Text, Text, Maybe Text)+parsePassword = withObject "password" (\obj -> do+ email' <- obj .: "new"+ pass <- obj .: "confirm"+ curr <- obj .:? "current"+ return (email', pass, curr))++postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent+postPasswordR = do+ maid <- maybeAuthId+ (creds :: Result Value) <- parseCheckJsonBody+ let jcreds = case creds of+ Error _ -> Nothing+ Success val -> parseMaybe parsePassword val+ let doJsonParsing = isJust jcreds+ case maid of+ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass+ Just aid -> do+ tm <- getRouteToParent+ needOld <- needOldPassword aid+ if not needOld then confirmPassword aid tm jcreds else do+ res <- runInputPostResult $ ireq textField "current"+ let fcurrent = case res of+ FormSuccess currentPass -> Just currentPass+ _ -> Nothing+ let current = if doJsonParsing+ then getThird jcreds+ else fcurrent+ mrealpass <- getPassword aid+ case (mrealpass, current) of+ (Nothing, _) ->+ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"+ (_, Nothing) ->+ loginErrorMessageI LoginR Msg.BadSetPass+ (Just realpass, Just current') -> do+ passValid <- verifyPassword current' realpass+ if passValid+ then confirmPassword aid tm jcreds+ else loginErrorMessage (tm setpassR) "Invalid current password, please try again"++ where+ msgOk = Msg.PassUpdated+ getThird (Just (_,_,t)) = t+ getThird Nothing = Nothing+ getNewConfirm (Just (a,b,_)) = Just (a,b)+ getNewConfirm _ = Nothing+ confirmPassword aid tm jcreds = do+ res <- runInputPostResult $ (,)+ <$> ireq textField "new"+ <*> ireq textField "confirm"+ let creds = if (isJust jcreds)+ then getNewConfirm jcreds+ else case res of+ FormSuccess res' -> Just res'+ _ -> Nothing+ case creds of+ Nothing -> loginErrorMessageI setpassR Msg.PassMismatch+ Just (new, confirm) ->+ if new /= confirm+ then loginErrorMessageI setpassR Msg.PassMismatch+ else do+ isSecure <- checkPasswordSecurity aid new+ case isSecure of+ Left e -> loginErrorMessage (tm setpassR) e+ Right () -> do+ salted <- hashAndSaltPassword new+ setPassword aid salted+ deleteSession loginLinkKey+ addMessageI "success" msgOk+ _ <- getYesod++ mr <- getMessageRender+ selectRep $ do+ provideRep $ do+ route <- afterPasswordRouteHandler+ fmap asHtml $ redirect route+ provideJsonMessage (mr msgOk)++saltLength :: Int+saltLength = 5++-- | Salt a password with a randomly generated salt.+saltPass :: Text -> IO Text+saltPass = fmap (decodeUtf8With lenientDecode)+ . flip PS.makePassword 16+ . encodeUtf8++saltPass' :: String -> String -> String+saltPass' salt pass =+ salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ convert (H.hash (TE.encodeUtf8 $ T.pack $ salt ++ pass) :: H.Digest H.MD5))++isValidPass :: Text -- ^ cleartext password+ -> SaltedPass -- ^ salted password+ -> Bool+isValidPass ct salted =+ PS.verifyPassword (encodeUtf8 ct) (encodeUtf8 salted) || isValidPass' ct salted++isValidPass' :: Text -- ^ cleartext password+ -> SaltedPass -- ^ salted password+ -> Bool+isValidPass' clear' salted' =+ let salt = take saltLength salted+ in salted == saltPass' salt clear+ where+ clear = TS.unpack clear'+ salted = TS.unpack salted'++-- | Session variable set when user logged in via a login link. See+-- 'needOldPassword'.+--+-- @since 1.2.1+loginLinkKey :: Text+loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK"++-- | Set 'loginLinkKey' to the current time.+--+-- @since 1.2.1+--setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()+setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))+ => AuthId (HandlerSite m)+ -> m ()+setLoginLinkKey aid = do+ now <- liftIO getCurrentTime+ setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)++-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this+-- use of unsafePerformIO.+defaultNonceGen :: Nonce.Generator+defaultNonceGen = unsafePerformIO (Nonce.new)+{-# NOINLINE defaultNonceGen #-}
− Yesod/Auth/GoogleEmail.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--- | Use an email address as an identifier via Google's OpenID login system.------ This backend will not use the OpenID identifier at all. It only uses OpenID--- as a login system. By using this plugin, you are trusting Google to validate--- an email address, and requiring users to have a Google account. On the plus--- side, you get to use email addresses as the identifier, many users have--- existing Google accounts, the login system has been long tested (as opposed--- to BrowserID), and it requires no credential managing or setup (as opposed--- to Email).-module Yesod.Auth.GoogleEmail- ( authGoogleEmail- , forwardUrl- ) where--import Yesod.Auth-import qualified Web.Authenticate.OpenId as OpenId--import Yesod.Handler-import Yesod.Widget (whamlet)-import Yesod.Request-#if MIN_VERSION_blaze_html(0, 5, 0)-import Text.Blaze.Html (toHtml)-#else-import Text.Blaze (toHtml)-#endif-import Data.Text (Text)-import qualified Yesod.Auth.Message as Msg-import qualified Data.Text as T-import Control.Exception.Lifted (try, SomeException)--pid :: Text-pid = "googleemail"--forwardUrl :: AuthRoute-forwardUrl = PluginR pid ["forward"]--googleIdent :: Text-googleIdent = "https://www.google.com/accounts/o8/id"--authGoogleEmail :: YesodAuth m => AuthPlugin m-authGoogleEmail =- AuthPlugin pid dispatch login- where- complete = PluginR pid ["complete"]- login tm =- [whamlet|-$newline never-<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}-|]- dispatch "GET" ["forward"] = do- render <- getUrlRender- toMaster <- getRouteToMaster- let complete' = render $ toMaster complete- master <- getYesod- eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing- [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")- , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")- , ("openid.ns.ax.required", "email")- , ("openid.ax.mode", "fetch_request")- , ("openid.ax.required", "email")- , ("openid.ui.icon", "true")- ] (authHttpManager master)- either- (\err -> do- setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR- )- redirect- eres- dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues- dispatch "GET" ["complete"] = do- rr <- getRequest- completeHelper $ reqGetParams rr- dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues- dispatch "POST" ["complete"] = do- (posts, _) <- runRequestBody- completeHelper posts- dispatch _ _ = notFound--completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()-completeHelper gets' = do- master <- getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- toMaster <- getRouteToMaster- let onFailure err = do- setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR- let onSuccess oir = do- let OpenId.Identifier ident = OpenId.oirOpLocal oir- memail <- lookupGetParam "openid.ext1.value.email"- case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of- (Just email, True) -> setCreds True $ Creds pid email []- (_, False) -> do- setMessage "Only Google login is supported"- redirect $ toMaster LoginR- (Nothing, _) -> do- setMessage "No email address provided"- redirect $ toMaster LoginR- either onFailure onSuccess eres
+ Yesod/Auth/GoogleEmail2.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | Use an email address as an identifier via Google's login system.+--+-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends+-- on Google's now deprecated OpenID system. For more information, see+-- <https://developers.google.com/+/api/auth-migration>.+--+-- By using this plugin, you are trusting Google to validate an email address,+-- and requiring users to have a Google account. On the plus side, you get to+-- use email addresses as the identifier, many users have existing Google+-- accounts, the login system has been long tested (as opposed to BrowserID),+-- and it requires no credential managing or setup (as opposed to Email).+--+-- In order to use this plugin:+--+-- * Create an application on the Google Developer Console <https://console.developers.google.com/>+--+-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)+--+-- * Enable the Google+ API.+--+-- @since 1.3.1+module Yesod.Auth.GoogleEmail2+ {-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-}+ ( -- * Authentication handlers+ authGoogleEmail+ , authGoogleEmailSaveToken+ , forwardUrl+ -- * User authentication token+ , Token(..)+ , getUserAccessToken+ -- * Person+ , getPerson+ , Person(..)+ , Name(..)+ , Gender(..)+ , PersonImage(..)+ , resizePersonImage+ , RelationshipStatus(..)+ , PersonURI(..)+ , PersonURIType(..)+ , Organization(..)+ , OrganizationType(..)+ , Place(..)+ , Email(..)+ , EmailType(..)+ -- * Other functions+ , pid+ ) where++import Yesod.Auth (Auth, AuthHandler,+ AuthPlugin (AuthPlugin),+ AuthRoute, Creds (Creds),+ Route (PluginR), YesodAuth,+ logoutDest, runHttpRequest,+ setCredsRedirect)+import qualified Yesod.Auth.Message as Msg+import Yesod.Core (HandlerSite, MonadHandler,+ TypedContent, addMessage,+ getRouteToParent, getUrlRender,+ getYesod, invalidArgs, liftIO,+ liftSubHandler, lookupGetParam,+ lookupSession, notFound, redirect,+ setSession, toHtml, whamlet, (.:))+++import Blaze.ByteString.Builder (fromByteString, toByteString)+import Control.Arrow (second)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO)+import qualified Crypto.Nonce as Nonce+import Data.Aeson ((.:?))+import qualified Data.Aeson as A+#if MIN_VERSION_aeson(1,0,0)+import qualified Data.Aeson.Text as A+#else+import qualified Data.Aeson.Encode as A+#endif+import Data.Aeson.Parser (json')+import Data.Aeson.Types (FromJSON (parseJSON), parseEither,+ parseMaybe, withObject, withText)+import Data.Conduit+import Data.Conduit.Attoparsec (sinkParser)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TL+import Network.HTTP.Client (Manager, requestHeaders,+ responseBody, urlEncodedBody)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.Conduit (Request, bodyReaderSource)+import Network.HTTP.Conduit (http)+import Network.HTTP.Types (renderQueryText)+import System.IO.Unsafe (unsafePerformIO)++#if MIN_VERSION_aeson(2, 0, 0)+import qualified Data.Aeson.Key+import qualified Data.Aeson.KeyMap+#else+import qualified Data.HashMap.Strict as M+#endif+++-- | Plugin identifier. This is used to identify the plugin used for+-- authentication. The 'credsPlugin' will contain this value when this+-- plugin is used for authentication.+-- @since 1.4.17+pid :: Text+pid = "googleemail2"++forwardUrl :: AuthRoute+forwardUrl = PluginR pid ["forward"]++csrfKey :: Text+csrfKey = "_GOOGLE_CSRF_TOKEN"++getCsrfToken :: MonadHandler m => m (Maybe Text)+getCsrfToken = lookupSession csrfKey++accessTokenKey :: Text+accessTokenKey = "_GOOGLE_ACCESS_TOKEN"++-- | Get user's access token from the session. Returns Nothing if it's not found+-- (probably because the user is not logged in via 'Yesod.Auth.GoogleEmail2'+-- or you are not using 'authGoogleEmailSaveToken')+getUserAccessToken :: MonadHandler m => m (Maybe Token)+getUserAccessToken = fmap (\t -> Token t "Bearer") <$> lookupSession accessTokenKey++getCreateCsrfToken :: MonadHandler m => m Text+getCreateCsrfToken = do+ mtoken <- getCsrfToken+ case mtoken of+ Just token -> return token+ Nothing -> do+ token <- Nonce.nonce128urlT defaultNonceGen+ setSession csrfKey token+ return token++authGoogleEmail :: YesodAuth m+ => Text -- ^ client ID+ -> Text -- ^ client secret+ -> AuthPlugin m+authGoogleEmail = authPlugin False++-- | An alternative version which stores user access token in the session+-- variable. Use it if you want to request user's profile from your app.+--+-- @since 1.4.3+authGoogleEmailSaveToken :: YesodAuth m+ => Text -- ^ client ID+ -> Text -- ^ client secret+ -> AuthPlugin m+authGoogleEmailSaveToken = authPlugin True++authPlugin :: YesodAuth m+ => Bool -- ^ if the token should be stored+ -> Text -- ^ client ID+ -> Text -- ^ client secret+ -> AuthPlugin m+authPlugin storeToken clientID clientSecret =+ AuthPlugin pid dispatch login+ where+ complete = PluginR pid ["complete"]++ getDest :: MonadHandler m+ => (Route Auth -> Route (HandlerSite m))+ -> m Text+ getDest tm = do+ csrf <- getCreateCsrfToken+ render <- getUrlRender+ let qs = map (second Just)+ [ ("scope", "email profile")+ , ("state", csrf)+ , ("redirect_uri", render $ tm complete)+ , ("response_type", "code")+ , ("client_id", clientID)+ , ("access_type", "offline")+ ]+ return $ decodeUtf8+ $ toByteString+ $ fromByteString "https://accounts.google.com/o/oauth2/auth"+ `mappend` renderQueryText True qs++ login tm = do+ [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]++ dispatch :: YesodAuth site+ => Text+ -> [Text]+ -> AuthHandler site TypedContent+ dispatch "GET" ["forward"] = do+ tm <- getRouteToParent+ getDest tm >>= redirect++ dispatch "GET" ["complete"] = do+ mstate <- lookupGetParam "state"+ case mstate of+ Nothing -> invalidArgs ["CSRF state from Google is missing"]+ Just state -> do+ mtoken <- getCsrfToken+ unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]+ mcode <- lookupGetParam "code"+ code <-+ case mcode of+ Nothing -> do+ merr <- lookupGetParam "error"+ case merr of+ Nothing -> invalidArgs ["Missing code paramter"]+ Just err -> do+ master <- getYesod+ let msg =+ case err of+ "access_denied" -> "Access denied"+ _ -> "Unknown error occurred: " `T.append` err+ addMessage "error" $ toHtml msg+ redirect $ logoutDest master+ Just c -> return c++ render <- getUrlRender+ tm <- getRouteToParent++ req' <- liftIO $+ HTTP.parseUrlThrow+ "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration+ let req =+ urlEncodedBody+ [ ("code", encodeUtf8 code)+ , ("client_id", encodeUtf8 clientID)+ , ("client_secret", encodeUtf8 clientSecret)+ , ("redirect_uri", encodeUtf8 $ render $ tm complete)+ , ("grant_type", "authorization_code")+ ]+ req'+ { requestHeaders = []+ }+ value <- makeHttpRequest req+ token@(Token accessToken' tokenType') <-+ case parseEither parseJSON value of+ Left e -> error e+ Right t -> return t++ unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'++ -- User's access token is saved for further access to API+ when storeToken $ setSession accessTokenKey accessToken'++ personValReq <- personValueRequest token+ personValue <- makeHttpRequest personValReq++ person <- case parseEither parseJSON personValue of+ Left e -> error e+ Right x -> return x++ email <-+ case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of+ [e] -> return e+ [] -> error "No account email"+ x -> error $ "Too many account emails: " ++ show x+ setCredsRedirect $ Creds pid email $ allPersonInfo personValue++ dispatch _ _ = notFound++makeHttpRequest :: Request -> AuthHandler site A.Value+makeHttpRequest req =+ liftSubHandler $ runHttpRequest req $ \res ->+ runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'++-- | Allows to fetch information about a user from Google's API.+-- In case of parsing error returns 'Nothing'.+-- Will throw 'HttpException' in case of network problems or error response code.+--+-- @since 1.4.3+getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)+getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do+ req <- personValueRequest token+ res <- http req manager+ runConduit $ responseBody res .| sinkParser json'+ )++personValueRequest :: MonadIO m => Token -> m Request+personValueRequest token = do+ req2' <- liftIO+ $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"+ return req2'+ { requestHeaders =+ [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)+ ]+ }++--------------------------------------------------------------------------------+-- | An authentication token which was acquired from OAuth callback.+-- The token gets saved into the session storage only if you use+-- 'authGoogleEmailSaveToken'.+-- You can acquire saved token with 'getUserAccessToken'.+--+-- @since 1.4.3+data Token = Token { accessToken :: Text+ , tokenType :: Text+ } deriving (Show, Eq)++instance FromJSON Token where+ parseJSON = withObject "Tokens" $ \o ->+ Token+ <$> o .: "access_token"+ <*> o .: "token_type"++--------------------------------------------------------------------------------+-- | Gender of the person+--+-- @since 1.4.3+data Gender = Male | Female | OtherGender deriving (Show, Eq)++instance FromJSON Gender where+ parseJSON = withText "Gender" $ \t -> return $ case t of+ "male" -> Male+ "female" -> Female+ _ -> OtherGender++--------------------------------------------------------------------------------+-- | URIs specified in the person's profile+--+-- @since 1.4.3+data PersonURI =+ PersonURI { uriLabel :: Maybe Text+ , uriValue :: Maybe Text+ , uriType :: Maybe PersonURIType+ } deriving (Show, Eq)++instance FromJSON PersonURI where+ parseJSON = withObject "PersonURI" $ \o -> PersonURI <$> o .:? "label"+ <*> o .:? "value"+ <*> o .:? "type"++--------------------------------------------------------------------------------+-- | The type of URI+--+-- @since 1.4.3+data PersonURIType = OtherProfile -- ^ URI for another profile+ | Contributor -- ^ URI to a site for which this person is a contributor+ | Website -- ^ URI for this Google+ Page's primary website+ | OtherURI -- ^ Other URL+ | PersonURIType Text -- ^ Something else+ deriving (Show, Eq)++instance FromJSON PersonURIType where+ parseJSON = withText "PersonURIType" $ \t -> return $ case t of+ "otherProfile" -> OtherProfile+ "contributor" -> Contributor+ "website" -> Website+ "other" -> OtherURI+ _ -> PersonURIType t++--------------------------------------------------------------------------------+-- | Current or past organizations with which this person is associated+--+-- @since 1.4.3+data Organization =+ Organization { orgName :: Maybe Text+ -- ^ The person's job title or role within the organization+ , orgTitle :: Maybe Text+ , orgType :: Maybe OrganizationType+ -- ^ The date that the person joined this organization.+ , orgStartDate :: Maybe Text+ -- ^ The date that the person left this organization.+ , orgEndDate :: Maybe Text+ -- ^ If @True@, indicates this organization is the person's+ -- ^ primary one, which is typically interpreted as the current one.+ , orgPrimary :: Maybe Bool+ } deriving (Show, Eq)++instance FromJSON Organization where+ parseJSON = withObject "Organization" $ \o ->+ Organization <$> o .:? "name"+ <*> o .:? "title"+ <*> o .:? "type"+ <*> o .:? "startDate"+ <*> o .:? "endDate"+ <*> o .:? "primary"++--------------------------------------------------------------------------------+-- | The type of an organization+--+-- @since 1.4.3+data OrganizationType = Work+ | School+ | OrganizationType Text -- ^ Something else+ deriving (Show, Eq)+instance FromJSON OrganizationType where+ parseJSON = withText "OrganizationType" $ \t -> return $ case t of+ "work" -> Work+ "school" -> School+ _ -> OrganizationType t++--------------------------------------------------------------------------------+-- | A place where the person has lived or is living at the moment.+--+-- @since 1.4.3+data Place =+ Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto".+ placeValue :: Maybe Text+ -- | If @True@, this place of residence is this person's primary residence.+ , placePrimary :: Maybe Bool+ } deriving (Show, Eq)++instance FromJSON Place where+ parseJSON = withObject "Place" $ \o -> Place <$> (o .:? "value") <*> (o .:? "primary")++--------------------------------------------------------------------------------+-- | Individual components of a name+--+-- @since 1.4.3+data Name =+ Name { -- | The full name of this person, including middle names, suffixes, etc+ nameFormatted :: Maybe Text+ -- | The family name (last name) of this person+ , nameFamily :: Maybe Text+ -- | The given name (first name) of this person+ , nameGiven :: Maybe Text+ -- | The middle name of this person.+ , nameMiddle :: Maybe Text+ -- | The honorific prefixes (such as "Dr." or "Mrs.") for this person+ , nameHonorificPrefix :: Maybe Text+ -- | The honorific suffixes (such as "Jr.") for this person+ , nameHonorificSuffix :: Maybe Text+ } deriving (Show, Eq)++instance FromJSON Name where+ parseJSON = withObject "Name" $ \o -> Name <$> o .:? "formatted"+ <*> o .:? "familyName"+ <*> o .:? "givenName"+ <*> o .:? "middleName"+ <*> o .:? "honorificPrefix"+ <*> o .:? "honorificSuffix"++--------------------------------------------------------------------------------+-- | The person's relationship status.+--+-- @since 1.4.3+data RelationshipStatus = Single -- ^ Person is single+ | InRelationship -- ^ Person is in a relationship+ | Engaged -- ^ Person is engaged+ | Married -- ^ Person is married+ | Complicated -- ^ The relationship is complicated+ | OpenRelationship -- ^ Person is in an open relationship+ | Widowed -- ^ Person is widowed+ | DomesticPartnership -- ^ Person is in a domestic partnership+ | CivilUnion -- ^ Person is in a civil union+ | RelationshipStatus Text -- ^ Something else+ deriving (Show, Eq)++instance FromJSON RelationshipStatus where+ parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of+ "single" -> Single+ "in_a_relationship" -> InRelationship+ "engaged" -> Engaged+ "married" -> Married+ "its_complicated" -> Complicated+ "open_relationship" -> OpenRelationship+ "widowed" -> Widowed+ "in_domestic_partnership" -> DomesticPartnership+ "in_civil_union" -> CivilUnion+ _ -> RelationshipStatus t++--------------------------------------------------------------------------------+-- | The URI of the person's profile photo.+--+-- @since 1.4.3+newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)++instance FromJSON PersonImage where+ parseJSON = withObject "PersonImage" $ \o -> PersonImage <$> o .: "url"++-- | @resizePersonImage img 30@ would set query part to @?sz=30@ which would resize+-- the image under the URI. If for some reason you need to modify the query+-- part, you should do it after resizing.+--+-- @since 1.4.3+resizePersonImage :: PersonImage -> Int -> PersonImage+resizePersonImage (PersonImage uri) size =+ PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)++--------------------------------------------------------------------------------+-- | Information about the user+-- Full description of the resource https://developers.google.com/+/api/latest/people+--+-- @since 1.4.3+data Person = Person+ { personId :: Text+ -- | The name of this person, which is suitable for display+ , personDisplayName :: Maybe Text+ , personName :: Maybe Name+ , personNickname :: Maybe Text+ , personBirthday :: Maybe Text -- ^ Birthday formatted as YYYY-MM-DD+ , personGender :: Maybe Gender+ , personProfileUri :: Maybe Text -- ^ The URI of this person's profile+ , personImage :: Maybe PersonImage+ , personAboutMe :: Maybe Text -- ^ A short biography for this person+ , personRelationshipStatus :: Maybe RelationshipStatus+ , personUris :: [PersonURI]+ , personOrganizations :: [Organization]+ , personPlacesLived :: [Place]+ -- | The brief description of this person+ , personTagline :: Maybe Text+ -- | Whether this user has signed up for Google++ , personIsPlusUser :: Maybe Bool+ -- | The "bragging rights" line of this person+ , personBraggingRights :: Maybe Text+ -- | if a Google+ page, the number of people who have +1'd this page+ , personPlusOneCount :: Maybe Int+ -- | For followers who are visible, the number of people who have added+ -- this person or page to a circle.+ , personCircledByCount :: Maybe Int+ -- | Whether the person or Google+ Page has been verified. This is used only+ -- for pages with a higher risk of being impersonated or similar. This+ -- flag will not be present on most profiles.+ , personVerified :: Maybe Bool+ -- | The user's preferred language for rendering.+ , personLanguage :: Maybe Text+ , personEmails :: [Email]+ , personDomain :: Maybe Text+ , personOccupation :: Maybe Text -- ^ The occupation of this person+ , personSkills :: Maybe Text -- ^ The person's skills+ } deriving (Show, Eq)+++instance FromJSON Person where+ parseJSON = withObject "Person" $ \o ->+ Person <$> o .: "id"+ <*> o .: "displayName"+ <*> o .:? "name"+ <*> o .:? "nickname"+ <*> o .:? "birthday"+ <*> o .:? "gender"+ <*> (o .:? "url")+ <*> o .:? "image"+ <*> o .:? "aboutMe"+ <*> o .:? "relationshipStatus"+ <*> ((fromMaybe []) <$> (o .:? "urls"))+ <*> ((fromMaybe []) <$> (o .:? "organizations"))+ <*> ((fromMaybe []) <$> (o .:? "placesLived"))+ <*> o .:? "tagline"+ <*> o .:? "isPlusUser"+ <*> o .:? "braggingRights"+ <*> o .:? "plusOneCount"+ <*> o .:? "circledByCount"+ <*> o .:? "verified"+ <*> o .:? "language"+ <*> ((fromMaybe []) <$> (o .:? "emails"))+ <*> o .:? "domain"+ <*> o .:? "occupation"+ <*> o .:? "skills"++--------------------------------------------------------------------------------+-- | Person's email+--+-- @since 1.4.3+data Email = Email+ { emailValue :: Text+ , emailType :: EmailType+ }+ deriving (Show, Eq)++instance FromJSON Email where+ parseJSON = withObject "Email" $ \o -> Email+ <$> o .: "value"+ <*> o .: "type"++--------------------------------------------------------------------------------+-- | Type of email+--+-- @since 1.4.3+data EmailType = EmailAccount -- ^ Google account email address+ | EmailHome -- ^ Home email address+ | EmailWork -- ^ Work email adress+ | EmailOther -- ^ Other email address+ | EmailType Text -- ^ Something else+ deriving (Show, Eq)++instance FromJSON EmailType where+ parseJSON = withText "EmailType" $ \t -> return $ case t of+ "account" -> EmailAccount+ "home" -> EmailHome+ "work" -> EmailWork+ "other" -> EmailOther+ _ -> EmailType t++allPersonInfo :: A.Value -> [(Text, Text)]+allPersonInfo (A.Object o) = map enc $ mapToList o+ where+ enc (key, A.String s) = (keyToText key, s)+ enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)++#if MIN_VERSION_aeson(2, 0, 0)+ keyToText = Data.Aeson.Key.toText+ mapToList = Data.Aeson.KeyMap.toList+#else+ keyToText = id+ mapToList = M.toList+#endif++allPersonInfo _ = []+++-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this+-- use of unsafePerformIO.+defaultNonceGen :: Nonce.Generator+defaultNonceGen = unsafePerformIO (Nonce.new)+{-# NOINLINE defaultNonceGen #-}
+ Yesod/Auth/Hardcoded.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module : Yesod.Auth.Hardcoded+Description : Very simple auth plugin for hardcoded auth pairs.+Copyright : (c) Arthur Fayzrakhmanov, 2015+License : MIT+Maintainer : heraldhoi@gmail.com+Stability : experimental++Sometimes you may want to have some hardcoded set of users (e.g. site managers)+that allowed to log in and visit some specific sections of your website without+ability to register new managers. This simple plugin is designed exactly for+this purpose.++Here is a quick usage example.++== Define hardcoded users representation++Let's assume, that we want to have some hardcoded managers with normal site+users. Let's define hardcoded user representation:++@+data SiteManager = SiteManager+ { manUserName :: Text+ , manPassWord :: Text }+ deriving Show++siteManagers :: [SiteManager]+siteManagers = [SiteManager "content editor" "top secret"]+@+++== Describe 'YesodAuth' instance++Now we need to have some convenient 'AuthId' type representing both+cases:++@+instance YesodAuth App where+ type AuthId App = Either UserId Text+@++Here, right @Text@ value will present hardcoded user name (which obviously must+be unique).++'AuthId' must have an instance of 'PathPiece' class, this is needed to store+user identifier in session (this happens in 'setCreds' and 'setCredsRedirect'+actions) and to read that identifier from session (this happens in+`defaultMaybeAuthId` action). So we have to define it:++@+import Text.Read (readMaybe)++instance PathPiece (Either UserId Text) where+ fromPathPiece = readMaybe . unpack+ toPathPiece = pack . show+@++Quiet simple so far. Now let's add plugin to 'authPlugins' list, and define+'authenticate' method, it should return user identifier for given credentials,+for normal users it is usually persistent key, for hardcoded users we will+return user name again.++@+instance YesodAuth App where+ -- ..+ authPlugins _ = [authHardcoded]++ authenticate Creds{..} =+ return+ (case credsPlugin of+ "hardcoded" ->+ case lookupUser credsIdent of+ Nothing -> UserError InvalidLogin+ Just m -> Authenticated (Right (manUserName m)))+@++Here @lookupUser@ is just a helper function to lookup hardcoded users by name:++@+lookupUser :: Text -> Maybe SiteManager+lookupUser username = find (\\m -> manUserName m == username) siteManagers+@+++== Describe an 'YesodAuthPersist' instance++Now we need to manually define 'YesodAuthPersist' instance.++> instance YesodAuthPersist App where+> type AuthEntity App = Either User SiteManager+>+> getAuthEntity (Left uid) =+> do x <- runDB (get uid)+> return (Left <$> x)+> getAuthEntity (Right username) = return (Right <$> lookupUser username)+++== Define 'YesodAuthHardcoded' instance++Finally, let's define an plugin instance++@+instance YesodAuthHardcoded App where+ validatePassword u = return . validPassword u+ doesUserNameExist = return . isJust . lookupUser++validPassword :: Text -> Text -> Bool+validPassword u p =+ case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of+ Just _ -> True+ _ -> False+@+++== Conclusion++Now we can use 'maybeAuthId', 'maybeAuthPair', 'requireAuthId', and+'requireAuthPair', moreover, the returned value makes possible to distinguish+normal users and site managers.+-}+module Yesod.Auth.Hardcoded+ ( YesodAuthHardcoded(..)+ , authHardcoded+ , loginR )+ where++import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute,+ Creds (..), Route (..), YesodAuth,+ loginErrorMessageI, setCredsRedirect)+import qualified Yesod.Auth.Message as Msg+import Yesod.Core+import Yesod.Form (ireq, runInputPost, textField)+import Data.Text (Text)+++loginR :: AuthRoute+loginR = PluginR "hardcoded" ["login"]++class (YesodAuth site) => YesodAuthHardcoded site where++ -- | Check whether given user name exists among hardcoded names.+ doesUserNameExist :: Text -> AuthHandler site Bool++ -- | Validate given user name with given password.+ validatePassword :: Text -> Text -> AuthHandler site Bool+++authHardcoded :: YesodAuthHardcoded m => AuthPlugin m+authHardcoded =+ AuthPlugin "hardcoded" dispatch loginWidget+ where+ dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent+ dispatch "POST" ["login"] = postLoginR >>= sendResponse+ dispatch _ _ = notFound+ loginWidget toMaster = do+ request <- getRequest+ [whamlet|+ $newline never+ <form method="post" action="@{toMaster loginR}">+ $maybe t <- reqToken request+ <input type=hidden name=#{defaultCsrfParamName} value=#{t}>+ <table>+ <tr>+ <th>_{Msg.UserName}+ <td>+ <input type="text" name="username" required>+ <tr>+ <th>_{Msg.Password}+ <td>+ <input type="password" name="password" required>+ <tr>+ <td colspan="2">+ <button type="submit" .btn .btn-success>_{Msg.LoginTitle}+ |]+++postLoginR :: YesodAuthHardcoded site+ => AuthHandler site TypedContent+postLoginR =+ do (username, password) <- runInputPost+ ((,) <$> ireq textField "username"+ <*> ireq textField "password")+ isValid <- validatePassword username password+ if isValid+ then setCredsRedirect (Creds "hardcoded" username [])+ else do isExists <- doesUserNameExist username+ loginErrorMessageI LoginR+ (if isExists+ then Msg.InvalidUsernamePass+ else Msg.IdentifierNotFound username)
− Yesod/Auth/HashDB.hs
@@ -1,316 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE CPP #-}----------------------------------------------------------------------------------- |--- Module : Yesod.Auth.HashDB--- Copyright : (c) Patrick Brisbin 2010 --- License : as-is------ Maintainer : pbrisbin@gmail.com--- Stability : Stable--- Portability : Portable------ A yesod-auth AuthPlugin designed to look users up in Persist where--- their user id's and a salted SHA1 hash of their password is stored.------ Example usage:------ > -- import the function--- > import Auth.HashDB--- >--- > -- make sure you have an auth route--- > mkYesodData "MyApp" [$parseRoutes|--- > / RootR GET--- > /auth AuthR Auth getAuth--- > |]--- >--- >--- > -- make your app an instance of YesodAuth using this plugin--- > instance YesodAuth MyApp where--- > type AuthId MyApp = UserId--- >--- > loginDest _ = RootR--- > logoutDest _ = RootR--- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)--- > authPlugins = [authHashDB (Just . UniqueUser)]--- >--- >--- > -- include the migration function in site startup--- > withServer :: (Application -> IO a) -> IO a--- > withServer f = withConnectionPool $ \p -> do--- > runSqlPool (runMigration migrateUsers) p--- > let h = DevSite p------ Note that function which converts username to unique identifier must be same.------ Your app must be an instance of YesodPersist. and the username,--- salt and hashed-passwords should be added to the database.------ > echo -n 'MySaltMyPassword' | sha1sum------ can be used to get the hash from the commandline.------------------------------------------------------------------------------------module Yesod.Auth.HashDB- ( HashDBUser(..)- , Unique (..)- , setPassword- -- * Authentification- , validateUser- , authHashDB- , getAuthIdHashDB- -- * Predefined data type- , User- , UserGeneric (..)- , UserId- , EntityField (..)- , migrateUsers- ) where--import Yesod.Persist-import Yesod.Handler-import Yesod.Form-import Yesod.Auth-import Yesod.Widget (toWidget)-import Text.Hamlet (hamlet)--import Control.Applicative ((<$>), (<*>))-import Control.Monad (replicateM,liftM)-import Control.Monad.IO.Class (MonadIO, liftIO)--import qualified Data.ByteString.Lazy.Char8 as BS (pack)-import Data.Digest.Pure.SHA (sha1, showDigest)-import Data.Text (Text, pack, unpack, append)-import Data.Maybe (fromMaybe)-import System.Random (randomRIO)---- | Interface for data type which holds user info. It's just a--- collection of getters and setters-class HashDBUser user where- -- | Retrieve password hash from user data- userPasswordHash :: user -> Maybe Text- -- | Retrieve salt for password- userPasswordSalt :: user -> Maybe Text-- -- | Deprecated for the better named setSaltAndPasswordHash - setUserHashAndSalt :: Text -- ^ Salt- -> Text -- ^ Password hash- -> user -> user- setUserHashAndSalt = setSaltAndPasswordHash-- -- | a callback for setPassword- setSaltAndPasswordHash :: Text -- ^ Salt- -> Text -- ^ Password hash- -> user -> user- setSaltAndPasswordHash = setUserHashAndSalt---- | Generate random salt. Length of 8 is chosen arbitrarily-randomSalt :: MonadIO m => m Text-randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))---- | Calculate salted hash using SHA1.-saltedHash :: Text -- ^ Salt- -> Text -- ^ Password- -> Text-saltedHash salt = - pack . showDigest . sha1 . BS.pack . unpack . append salt---- | Set password for user. This function should be used for setting--- passwords. It generates random salt and calculates proper hashes.-setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user-setPassword pwd u = do salt <- randomSalt- return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u---------------------------------------------------------------------- Authentification--------------------------------------------------------------------- | Given a user ID and password in plaintext, validate them against--- the database values.-validateUser :: ( YesodPersist yesod-#if MIN_VERSION_persistent(1, 1, 0)- , b ~ YesodPersistBackend yesod- , PersistMonadBackend (b (GHandler sub yesod)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler sub yesod))-#else- , b ~ YesodPersistBackend yesod- , b ~ PersistEntityBackend user- , PersistStore b (GHandler sub yesod)- , PersistUnique b (GHandler sub yesod)-#endif- , PersistEntity user- , HashDBUser user- ) => -#if MIN_VERSION_persistent(1, 1, 0)- Unique user -- ^ User unique identifier-#else- Unique user b -- ^ User unique identifier-#endif- -> Text -- ^ Password in plaint-text- -> GHandler sub yesod Bool-validateUser userID passwd = do- -- Checks that hash and password match- let validate u = do hash <- userPasswordHash u- salt <- userPasswordSalt u- return $ hash == saltedHash salt passwd- -- Get user data- user <- runDB $ getBy userID- return $ fromMaybe False $ validate . entityVal =<< user---login :: AuthRoute-login = PluginR "hashdb" ["login"]----- | Handle the login form. First parameter is function which maps--- username (whatever it might be) to unique user ID.-postLoginR :: ( YesodAuth y, YesodPersist y- , HashDBUser user, PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0)- , b ~ YesodPersistBackend y- , PersistMonadBackend (b (GHandler Auth y)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler Auth y))-#else- , b ~ YesodPersistBackend y- , b ~ PersistEntityBackend user- , PersistStore b (GHandler Auth y)- , PersistUnique b (GHandler Auth y)-#endif- )-#if MIN_VERSION_persistent(1, 1, 0)- => (Text -> Maybe (Unique user))-#else- => (Text -> Maybe (Unique user b))-#endif- -> GHandler Auth y ()-postLoginR uniq = do- (mu,mp) <- runInputPost $ (,)- <$> iopt textField "username"- <*> iopt textField "password"-- isValid <- fromMaybe (return False) - (validateUser <$> (uniq =<< mu) <*> mp)- if isValid - then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do setMessage "Invalid username/password"- toMaster <- getRouteToMaster- redirect $ toMaster LoginR----- | A drop in for the getAuthId method of your YesodAuth instance which--- can be used if authHashDB is the only plugin in use.-getAuthIdHashDB :: ( YesodAuth master, YesodPersist master- , HashDBUser user, PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0)- , Key user ~ AuthId master- , b ~ YesodPersistBackend master- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler sub master))-#else- , Key b user ~ AuthId master- , b ~ YesodPersistBackend master- , b ~ PersistEntityBackend user- , PersistUnique b (GHandler sub master)- , PersistStore b (GHandler sub master)-#endif- )- => (AuthRoute -> Route master) -- ^ your site's Auth Route-#if MIN_VERSION_persistent(1, 1, 0)- -> (Text -> Maybe (Unique user)) -- ^ gets user ID-#else- -> (Text -> Maybe (Unique user b)) -- ^ gets user ID-#endif- -> Creds master -- ^ the creds argument- -> GHandler sub master (Maybe (AuthId master))-getAuthIdHashDB authR uniq creds = do- muid <- maybeAuthId- case muid of- -- user already authenticated- Just uid -> return $ Just uid- Nothing -> do- x <- case uniq (credsIdent creds) of- Nothing -> return Nothing- Just u -> runDB (getBy u)- case x of- -- user exists- Just (Entity uid _) -> return $ Just uid- Nothing -> do- setMessage "User not found"- redirect $ authR LoginR---- | Prompt for username and password, validate that against a database--- which holds the username and a hash of the password-authHashDB :: ( YesodAuth m, YesodPersist m- , HashDBUser user- , PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0)- , b ~ YesodPersistBackend m- , PersistMonadBackend (b (GHandler Auth m)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler Auth m)))- => (Text -> Maybe (Unique user)) -> AuthPlugin m-#else- , b ~ YesodPersistBackend m- , b ~ PersistEntityBackend user- , PersistStore b (GHandler Auth m)- , PersistUnique b (GHandler Auth m))- => (Text -> Maybe (Unique user b)) -> AuthPlugin m-#endif-authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|-$newline never- <div id="header">- <h1>Login-- <div id="login">- <form method="post" action="@{tm login}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login">-- <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }--|]- where- dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse- dispatch _ _ = notFound---------------------------------------------------------------------- Predefined datatype--------------------------------------------------------------------- | Generate data base instances for a valid user-share [mkPersist sqlSettings, mkMigrate "migrateUsers"]- [persistUpperCase|-User- username Text Eq- password Text- salt Text- UniqueUser username-|]--instance HashDBUser (UserGeneric backend) where- userPasswordHash = Just . userPassword- userPasswordSalt = Just . userSalt- setSaltAndPasswordHash s h u = u { userSalt = s- , userPassword = h- }
Yesod/Auth/Message.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Auth.Message ( AuthMessage (..) , defaultMessage@@ -12,9 +13,17 @@ , norwegianBokmålMessage , japaneseMessage , finnishMessage+ , chineseMessage+ , croatianMessage+ , spanishMessage+ , czechMessage+ , russianMessage+ , dutchMessage+ , danishMessage+ , koreanMessage+ , romanianMessage ) where -import Data.Monoid (mappend) import Data.Text (Text) data AuthMessage =@@ -23,6 +32,8 @@ | LoginGoogle | LoginYahoo | Email+ | UserName+ | IdentifierNotFound Text | Password | Register | RegisterLong@@ -30,6 +41,8 @@ | ConfirmationEmailSentTitle | ConfirmationEmailSent Text | AddressVerified+ | EmailVerifiedChangePass+ | EmailVerified | InvalidKeyTitle | InvalidKey | InvalidEmailPass@@ -47,6 +60,19 @@ | LoginTitle | PleaseProvideUsername | PleaseProvidePassword+ | NoIdentifierProvided+ | InvalidEmailAddress+ | PasswordResetTitle+ | ProvideIdentifier+ | SendPasswordResetEmail+ | PasswordResetPrompt+ | CurrentPassword+ | InvalidUsernamePass+ | Logout+ | LogoutTitle+ | AuthError+{-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}+{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-} -- | Defaults to 'englishMessage'. defaultMessage :: AuthMessage -> Text@@ -54,20 +80,22 @@ englishMessage :: AuthMessage -> Text englishMessage NoOpenID = "No OpenID identifier found"-englishMessage LoginOpenID = "Login via OpenID"-englishMessage LoginGoogle = "Login via Google"-englishMessage LoginYahoo = "Login via Yahoo"+englishMessage LoginOpenID = "Log in via OpenID"+englishMessage LoginGoogle = "Log in via Google"+englishMessage LoginYahoo = "Log in via Yahoo" englishMessage Email = "Email"+englishMessage UserName = "User name" englishMessage Password = "Password"+englishMessage CurrentPassword = "Current Password" englishMessage Register = "Register" englishMessage RegisterLong = "Register a new account" englishMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." englishMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent" englishMessage (ConfirmationEmailSent email) =- "A confirmation e-mail has been sent to " `mappend`- email `mappend`- "."-englishMessage AddressVerified = "Address verified, please set a new password"+ "A confirmation e-mail has been sent to " `mappend` email `mappend` "."+englishMessage AddressVerified = "Email address verified, please set a new password"+englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password"+englishMessage EmailVerified = "Email address verified" englishMessage InvalidKeyTitle = "Invalid verification key" englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key." englishMessage InvalidEmailPass = "Invalid email/password combination"@@ -78,13 +106,24 @@ englishMessage ConfirmPass = "Confirm" englishMessage PassMismatch = "Passwords did not match, please try again" englishMessage PassUpdated = "Password updated"-englishMessage Facebook = "Login with Facebook"-englishMessage LoginViaEmail = "Login via email"+englishMessage Facebook = "Log in with Facebook"+englishMessage LoginViaEmail = "Log in via email" englishMessage InvalidLogin = "Invalid login" englishMessage NowLoggedIn = "You are now logged in"-englishMessage LoginTitle = "Login"+englishMessage LoginTitle = "Log In" englishMessage PleaseProvideUsername = "Please fill in your username" englishMessage PleaseProvidePassword = "Please fill in your password"+englishMessage NoIdentifierProvided = "No email/username provided"+englishMessage InvalidEmailAddress = "Invalid email address provided"+englishMessage PasswordResetTitle = "Password Reset"+englishMessage ProvideIdentifier = "Email or Username"+englishMessage SendPasswordResetEmail = "Send password reset email"+englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+englishMessage InvalidUsernamePass = "Invalid username/password combination"+englishMessage (IdentifierNotFound ident) = "Login not found: " `mappend` ident+englishMessage Logout = "Log Out"+englishMessage LogoutTitle = "Log Out"+englishMessage AuthError = "Authentication Error" -- FIXME by Google Translate portugueseMessage :: AuthMessage -> Text portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"@@ -92,7 +131,9 @@ portugueseMessage LoginGoogle = "Entrar via Google" portugueseMessage LoginYahoo = "Entrar via Yahoo" portugueseMessage Email = "E-mail"+portugueseMessage UserName = "Nome de usuário" -- FIXME by Google Translate "user name" portugueseMessage Password = "Senha"+portugueseMessage CurrentPassword = "Palavra de passe" portugueseMessage Register = "Registrar" portugueseMessage RegisterLong = "Registrar uma nova conta" portugueseMessage EnterEmail = "Por favor digite seu endereço de e-mail abaixo e um e-mail de confirmação será enviado para você."@@ -102,6 +143,8 @@ email `mappend` "." portugueseMessage AddressVerified = "Endereço verificado, por favor entre com uma nova senha"+portugueseMessage EmailVerifiedChangePass = "Endereço verificado, por favor entre com uma nova senha"+portugueseMessage EmailVerified = "Endereço verificado" portugueseMessage InvalidKeyTitle = "Chave de verificação inválida" portugueseMessage InvalidKey = "Por favor nos desculpe, mas essa é uma chave de verificação inválida." portugueseMessage InvalidEmailPass = "E-mail e/ou senha inválidos"@@ -119,14 +162,78 @@ portugueseMessage LoginTitle = "Entrar no site" portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário" portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"+portugueseMessage NoIdentifierProvided = "Nenhum e-mail ou nome de usuário informado"+portugueseMessage InvalidEmailAddress = "Endereço de e-mail inválido informado"+portugueseMessage PasswordResetTitle = "Resetar senha"+portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"+portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"+portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo. Um e-mail para resetar sua senha será enviado para você."+portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"+-- TODO+portugueseMessage i@(IdentifierNotFound _) = englishMessage i+portugueseMessage Logout = "Sair" -- FIXME by Google Translate+portugueseMessage LogoutTitle = "Sair" -- FIXME by Google Translate+portugueseMessage AuthError = "Erro de autenticação" -- FIXME by Google Translate +spanishMessage :: AuthMessage -> Text+spanishMessage NoOpenID = "No se encuentra el identificador OpenID"+spanishMessage LoginOpenID = "Entrar utilizando OpenID"+spanishMessage LoginGoogle = "Entrar utilizando Google"+spanishMessage LoginYahoo = "Entrar utilizando Yahoo"+spanishMessage Email = "Correo electrónico"+spanishMessage UserName = "Nombre de Usuario"+spanishMessage Password = "Contraseña"+spanishMessage CurrentPassword = "Contraseña actual"+spanishMessage Register = "Registrarse"+spanishMessage RegisterLong = "Registrar una nueva cuenta"+spanishMessage EnterEmail = "Coloque su dirección de correo electrónico, y un correo de confirmación le será enviado a su cuenta."+spanishMessage ConfirmationEmailSentTitle = "La confirmación de correo ha sido enviada"+spanishMessage (ConfirmationEmailSent email) =+ "Una confirmación de correo electrónico ha sido enviada a " `mappend`+ email `mappend`+ "."+spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"+spanishMessage EmailVerifiedChangePass = "Dirección verificada, por favor introduzca una contraseña"+spanishMessage EmailVerified = "Dirección verificada"+spanishMessage InvalidKeyTitle = "Clave de verificación invalida"+spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."+spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"+spanishMessage BadSetPass = "Debe acceder a la aplicación para modificar la contraseña"+spanishMessage SetPassTitle = "Modificar contraseña"+spanishMessage SetPass = "Actualizar nueva contraseña"+spanishMessage NewPass = "Nueva contraseña"+spanishMessage ConfirmPass = "Confirmar"+spanishMessage PassMismatch = "Las contraseñas no coinciden, inténtelo de nuevo"+spanishMessage PassUpdated = "Contraseña actualizada"+spanishMessage Facebook = "Entrar mediante Facebook"+spanishMessage LoginViaEmail = "Entrar mediante una cuenta de correo"+spanishMessage InvalidLogin = "Login inválido"+spanishMessage NowLoggedIn = "Usted ha ingresado al sitio"+spanishMessage LoginTitle = "Log In"+spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"+spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"+spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"+spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"+spanishMessage PasswordResetTitle = "Actualización de contraseña"+spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"+spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña"+spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."+spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"+-- TODO+spanishMessage i@(IdentifierNotFound _) = englishMessage i+spanishMessage Logout = "Finalizar la sesión" -- FIXME by Google Translate+spanishMessage LogoutTitle = "Finalizar la sesión" -- FIXME by Google Translate+spanishMessage AuthError = "Error de autenticación" -- FIXME by Google Translate+ swedishMessage :: AuthMessage -> Text swedishMessage NoOpenID = "Fann ej OpenID identifierare" swedishMessage LoginOpenID = "Logga in via OpenID" swedishMessage LoginGoogle = "Logga in via Google" swedishMessage LoginYahoo = "Logga in via Yahoo" swedishMessage Email = "Epost"+swedishMessage UserName = "Användarnamn" -- FIXME by Google Translate "user name" swedishMessage Password = "Lösenord"+swedishMessage CurrentPassword = "Current password" swedishMessage Register = "Registrera" swedishMessage RegisterLong = "Registrera ett nytt konto" swedishMessage EnterEmail = "Skriv in din epost nedan så kommer ett konfirmationsmail skickas till adressen."@@ -136,6 +243,8 @@ email `mappend` "." swedishMessage AddressVerified = "Adress verifierad, vänligen välj nytt lösenord"+swedishMessage EmailVerifiedChangePass = "Adress verifierad, vänligen välj nytt lösenord"+swedishMessage EmailVerified = "Adress verifierad" swedishMessage InvalidKeyTitle = "Ogiltig verifikationsnyckel" swedishMessage InvalidKey = "Tyvärr, du angav en ogiltig verifimationsnyckel." swedishMessage InvalidEmailPass = "Ogiltig epost/lösenord kombination"@@ -153,23 +262,40 @@ swedishMessage LoginTitle = "Logga in" swedishMessage PleaseProvideUsername = "Vänligen fyll i användarnamn" swedishMessage PleaseProvidePassword = "Vänligen fyll i lösenord"+swedishMessage NoIdentifierProvided = "Emailadress eller användarnamn saknas"+swedishMessage InvalidEmailAddress = "Ogiltig emailadress angiven"+swedishMessage PasswordResetTitle = "Återställning av lösenord"+swedishMessage ProvideIdentifier = "Epost eller användarnamn"+swedishMessage SendPasswordResetEmail = "Skicka email för återställning av lösenord"+swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`+ "ett email för återställning av lösenord kommmer att skickas till dig."+swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord"+-- TODO+swedishMessage i@(IdentifierNotFound _) = englishMessage i+swedishMessage Logout = "Loggar ut" -- FIXME by Google Translate+swedishMessage LogoutTitle = "Loggar ut" -- FIXME by Google Translate+swedishMessage AuthError = "Autentisering Fel" -- FIXME by Google Translate germanMessage :: AuthMessage -> Text germanMessage NoOpenID = "Kein OpenID-Identifier gefunden" germanMessage LoginOpenID = "Login via OpenID" germanMessage LoginGoogle = "Login via Google" germanMessage LoginYahoo = "Login via Yahoo"-germanMessage Email = "Email"+germanMessage Email = "E-Mail"+germanMessage UserName = "Benutzername" germanMessage Password = "Passwort"+germanMessage CurrentPassword = "Aktuelles Passwort" germanMessage Register = "Registrieren" germanMessage RegisterLong = "Neuen Account registrieren"-germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."+germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt." germanMessage (ConfirmationEmailSent email) = "Eine Bestätigung wurde an " `mappend` email `mappend`- "versandt."+ " versandt." germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"+germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"+germanMessage EmailVerified = "Adresse bestätigt" germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel" germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel" germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"@@ -178,17 +304,26 @@ germanMessage SetPass = "Neues Passwort angeben" germanMessage NewPass = "Neues Passwort" germanMessage ConfirmPass = "Bestätigen"-germanMessage PassMismatch = "Die Passwörter stimmten nicht überein"+germanMessage PassMismatch = "Die Passwörter stimmen nicht überein" germanMessage PassUpdated = "Passwort überschrieben" germanMessage Facebook = "Login über Facebook"-germanMessage LoginViaEmail = "Login via e-Mail"+germanMessage LoginViaEmail = "Login via E-Mail" germanMessage InvalidLogin = "Ungültiger Login" germanMessage NowLoggedIn = "Login erfolgreich"-germanMessage LoginTitle = "Login"+germanMessage LoginTitle = "Anmelden" germanMessage PleaseProvideUsername = "Bitte Nutzername angeben" germanMessage PleaseProvidePassword = "Bitte Passwort angeben"--+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter"+germanMessage PasswordResetTitle = "Passwort zurücksetzen"+germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"+germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"+germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann."+germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"+germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO+germanMessage Logout = "Abmelden"+germanMessage LogoutTitle = "Abmelden"+germanMessage AuthError = "Fehler beim Anmelden" frenchMessage :: AuthMessage -> Text frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"@@ -196,7 +331,9 @@ frenchMessage LoginGoogle = "Se connecter avec Google" frenchMessage LoginYahoo = "Se connecter avec Yahoo" frenchMessage Email = "Adresse électronique"+frenchMessage UserName = "Nom d'utilisateur" -- FIXME by Google Translate "user name" frenchMessage Password = "Mot de passe"+frenchMessage CurrentPassword = "Mot de passe actuel" frenchMessage Register = "S'inscrire" frenchMessage RegisterLong = "Créer un compte" frenchMessage EnterEmail = "Entrez ci-dessous votre adresse électronique, et un message de confirmation vous sera envoyé"@@ -206,9 +343,11 @@ email `mappend` "." frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."+frenchMessage EmailVerifiedChangePass = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."+frenchMessage EmailVerified = "Votre adresse électronique a été validée" frenchMessage InvalidKeyTitle = "Clef de validation incorrecte" frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte"-frenchMessage InvalidEmailPass = "Le couple mot de passe/adresse électronique n'est pas correct"+frenchMessage InvalidEmailPass = "La combinaison de ce mot de passe et de cette adresse électronique n'existe pas." frenchMessage BadSetPass = "Vous devez être connecté pour choisir un mot de passe" frenchMessage SetPassTitle = "Changer de mot de passe" frenchMessage SetPass = "Choisir un nouveau mot de passe"@@ -217,12 +356,23 @@ frenchMessage PassMismatch = "Le deux mots de passe sont différents, veuillez les corriger" frenchMessage PassUpdated = "Le mot de passe a bien été changé" frenchMessage Facebook = "Se connecter avec Facebook"-frenchMessage LoginViaEmail = "Se connecter à l'aide d'une adresse électronique"+frenchMessage LoginViaEmail = "Se connecter avec une adresse électronique" frenchMessage InvalidLogin = "Nom d'utilisateur incorrect" frenchMessage NowLoggedIn = "Vous êtes maintenant connecté" frenchMessage LoginTitle = "Se connecter"-frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"-frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"+frenchMessage PleaseProvideUsername = "Veuillez fournir votre nom d'utilisateur"+frenchMessage PleaseProvidePassword = "Veuillez fournir votre mot de passe"+frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"+frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"+frenchMessage PasswordResetTitle = "Réinitialisation du mot de passe"+frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"+frenchMessage SendPasswordResetEmail = "Envoi d'un courriel pour réinitialiser le mot de passe"+frenchMessage PasswordResetPrompt = "Entrez votre courriel ou votre nom d'utilisateur ci-dessous, et vous recevrez un message électronique pour réinitialiser votre mot de passe."+frenchMessage InvalidUsernamePass = "La combinaison de ce mot de passe et de ce nom d'utilisateur n'existe pas."+frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident+frenchMessage Logout = "Déconnexion"+frenchMessage LogoutTitle = "Déconnexion"+frenchMessage AuthError = "Erreur d'authentification" -- FIXME by Google Translate norwegianBokmålMessage :: AuthMessage -> Text norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"@@ -230,7 +380,9 @@ norwegianBokmålMessage LoginGoogle = "Logg inn med Google" norwegianBokmålMessage LoginYahoo = "Logg inn med Yahoo" norwegianBokmålMessage Email = "E-post"+norwegianBokmålMessage UserName = "Brukernavn" -- FIXME by Google Translate "user name" norwegianBokmålMessage Password = "Passord"+norwegianBokmålMessage CurrentPassword = "Current password" norwegianBokmålMessage Register = "Registrer" norwegianBokmålMessage RegisterLong = "Registrer en ny konto" norwegianBokmålMessage EnterEmail = "Skriv inn e-postadressen din nedenfor og en e-postkonfirmasjon vil bli sendt."@@ -240,6 +392,8 @@ email `mappend` "." norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."+norwegianBokmålMessage EmailVerifiedChangePass = "Adresse verifisert, vennligst sett et nytt passord."+norwegianBokmålMessage EmailVerified = "Adresse verifisert" norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel" norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel." norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"@@ -257,6 +411,18 @@ norwegianBokmålMessage LoginTitle = "Logg inn" norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn" norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"+norwegianBokmålMessage NoIdentifierProvided = "No email/username provided"+norwegianBokmålMessage InvalidEmailAddress = "Invalid email address provided"+norwegianBokmålMessage PasswordResetTitle = "Password Reset"+norwegianBokmålMessage ProvideIdentifier = "Email or Username"+norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"+norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"+-- TODO+norwegianBokmålMessage i@(IdentifierNotFound _) = englishMessage i+norwegianBokmålMessage Logout = "Logge ut" -- FIXME by Google Translate+norwegianBokmålMessage LogoutTitle = "Logge ut" -- FIXME by Google Translate+norwegianBokmålMessage AuthError = "Godkjenningsfeil" -- FIXME by Google Translate japaneseMessage :: AuthMessage -> Text japaneseMessage NoOpenID = "OpenID識別子がありません"@@ -264,7 +430,9 @@ japaneseMessage LoginGoogle = "Googleでログイン" japaneseMessage LoginYahoo = "Yahooでログイン" japaneseMessage Email = "Eメール"+japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name" japaneseMessage Password = "パスワード"+japaneseMessage CurrentPassword = "現在のパスワード" japaneseMessage Register = "登録" japaneseMessage RegisterLong = "新規アカウント登録" japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"@@ -274,6 +442,8 @@ email `mappend` " に送信しました" japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerified = "アドレスは認証されました" japaneseMessage InvalidKeyTitle = "認証キーが無効です" japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです" japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"@@ -291,6 +461,18 @@ japaneseMessage LoginTitle = "ログイン" japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください" japaneseMessage PleaseProvidePassword = "パスワードを入力してください"+japaneseMessage NoIdentifierProvided = "メールアドレス/ユーザ名が入力されていません"+japaneseMessage InvalidEmailAddress = "メールアドレスが無効です"+japaneseMessage PasswordResetTitle = "パスワードの再設定"+japaneseMessage ProvideIdentifier = "メールアドレスまたはユーザ名"+japaneseMessage SendPasswordResetEmail = "パスワード再設定用メールの送信"+japaneseMessage PasswordResetPrompt = "以下にメールアドレスまたはユーザ名を入力してください。パスワードを再設定するためのメールが送信されます。"+japaneseMessage InvalidUsernamePass = "ユーザ名とパスワードの組み合わせが間違っています"+japaneseMessage (IdentifierNotFound ident) =+ ident `mappend` "は登録されていません"+japaneseMessage Logout = "ログアウト" -- FIXME by Google Translate+japaneseMessage LogoutTitle = "ログアウト" -- FIXME by Google Translate+japaneseMessage AuthError = "認証エラー" -- FIXME by Google Translate finnishMessage :: AuthMessage -> Text finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"@@ -298,7 +480,9 @@ finnishMessage LoginGoogle = "Kirjaudu Google-tilillä" finnishMessage LoginYahoo = "Kirjaudu Yahoo-tilillä" finnishMessage Email = "Sähköposti"+finnishMessage UserName = "Käyttäjätunnus" -- FIXME by Google Translate "user name" finnishMessage Password = "Salasana"+finnishMessage CurrentPassword = "Current password" finnishMessage Register = "Luo uusi" finnishMessage RegisterLong = "Luo uusi tili" finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."@@ -307,7 +491,10 @@ "Vahvistussähköposti on lähetty osoitteeseen " `mappend` email `mappend` "."+ finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"+finnishMessage EmailVerifiedChangePass = "Sähköpostiosoite vahvistettu. Anna uusi salasana"+finnishMessage EmailVerified = "Sähköpostiosoite vahvistettu" finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain" finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen." finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."@@ -325,5 +512,407 @@ finnishMessage LoginTitle = "Kirjautuminen" finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu" finnishMessage PleaseProvidePassword = "Salasana puuttuu"+finnishMessage NoIdentifierProvided = "Sähköpostiosoite/käyttäjänimi puuttuu"+finnishMessage InvalidEmailAddress = "Annettu sähköpostiosoite ei kelpaa"+finnishMessage PasswordResetTitle = "Uuden salasanan tilaaminen"+finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"+finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"+finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."+finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."+-- TODO+finnishMessage i@(IdentifierNotFound _) = englishMessage i+finnishMessage Logout = "Kirjaudu ulos" -- FIXME by Google Translate+finnishMessage LogoutTitle = "Kirjaudu ulos" -- FIXME by Google Translate+finnishMessage AuthError = "Authentication Error" -- FIXME by Google Translate +chineseMessage :: AuthMessage -> Text+chineseMessage NoOpenID = "无效的OpenID"+chineseMessage LoginOpenID = "用OpenID登录"+chineseMessage LoginGoogle = "用Google帐户登录"+chineseMessage LoginYahoo = "用Yahoo帐户登录"+chineseMessage Email = "邮箱"+chineseMessage UserName = "用户名"+chineseMessage Password = "密码"+chineseMessage CurrentPassword = "当前密码"+chineseMessage Register = "注册"+chineseMessage RegisterLong = "注册新帐户"+chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"+chineseMessage ConfirmationEmailSentTitle = "确认邮件已发送"+chineseMessage (ConfirmationEmailSent email) =+ "确认邮件已发送至 " `mappend`+ email `mappend`+ "."+chineseMessage AddressVerified = "地址验证成功，请设置新密码"+chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"+chineseMessage EmailVerified = "地址验证成功"+chineseMessage InvalidKeyTitle = "无效的验证码"+chineseMessage InvalidKey = "对不起，验证码无效。"+chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"+chineseMessage BadSetPass = "你需要登录才能设置密码"+chineseMessage SetPassTitle = "设置密码"+chineseMessage SetPass = "设置新密码"+chineseMessage NewPass = "新密码"+chineseMessage ConfirmPass = "确认"+chineseMessage PassMismatch = "密码不匹配，请重新输入"+chineseMessage PassUpdated = "密码更新成功"+chineseMessage Facebook = "用Facebook帐户登录"+chineseMessage LoginViaEmail = "用邮箱登录"+chineseMessage InvalidLogin = "登录失败"+chineseMessage NowLoggedIn = "登录成功"+chineseMessage LoginTitle = "登录"+chineseMessage PleaseProvideUsername = "请输入用户名"+chineseMessage PleaseProvidePassword = "请输入密码"+chineseMessage NoIdentifierProvided = "缺少邮箱/用户名"+chineseMessage InvalidEmailAddress = "无效的邮箱地址"+chineseMessage PasswordResetTitle = "重置密码"+chineseMessage ProvideIdentifier = "邮箱或用户名"+chineseMessage SendPasswordResetEmail = "发送密码重置邮件"+chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"+chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"+chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident+chineseMessage Logout = "注销"+chineseMessage LogoutTitle = "注销"+chineseMessage AuthError = "验证错误" +czechMessage :: AuthMessage -> Text+czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"+czechMessage LoginOpenID = "Přihlásit přes OpenID"+czechMessage LoginGoogle = "Přihlásit přes Google"+czechMessage LoginYahoo = "Přihlásit přes Yahoo"+czechMessage Email = "E-mail"+czechMessage UserName = "Uživatelské jméno"+czechMessage Password = "Heslo"+czechMessage CurrentPassword = "Current password"+czechMessage Register = "Registrovat"+czechMessage RegisterLong = "Zaregistrovat nový účet"+czechMessage EnterEmail = "Níže zadejte svou e-mailovou adresu a bude vám poslán potvrzovací e-mail."+czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"+czechMessage (ConfirmationEmailSent email) =+ "Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."+czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"+czechMessage EmailVerifiedChangePass = "Adresa byla ověřena, prosím nastavte si nové heslo"+czechMessage EmailVerified = "Adresa byla ověřena"+czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"+czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."+czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"+czechMessage BadSetPass = "Pro nastavení hesla je vyžadováno přihlášení"+czechMessage SetPassTitle = "Nastavit heslo"+czechMessage SetPass = "Nastavit nové heslo"+czechMessage NewPass = "Nové heslo"+czechMessage ConfirmPass = "Potvrdit"+czechMessage PassMismatch = "Hesla si neodpovídají, zkuste to znovu"+czechMessage PassUpdated = "Heslo aktualizováno"+czechMessage Facebook = "Přihlásit přes Facebook"+czechMessage LoginViaEmail = "Přihlásit přes e-mail"+czechMessage InvalidLogin = "Neplatné přihlášení"+czechMessage NowLoggedIn = "Přihlášení proběhlo úspěšně"+czechMessage LoginTitle = "Přihlásit"+czechMessage PleaseProvideUsername = "Prosím, zadejte svoje uživatelské jméno"+czechMessage PleaseProvidePassword = "Prosím, zadejte svoje heslo"+czechMessage NoIdentifierProvided = "Nebyl poskytnut žádný e-mail nebo uživatelské jméno"+czechMessage InvalidEmailAddress = "Zadaná e-mailová adresa je neplatná"+czechMessage PasswordResetTitle = "Obnovení hesla"+czechMessage ProvideIdentifier = "E-mail nebo uživatelské jméno"+czechMessage SendPasswordResetEmail = "Poslat e-mail pro obnovení hesla"+czechMessage PasswordResetPrompt = "Zadejte svou e-mailovou adresu nebo uživatelské jméno a bude vám poslán email pro obnovení hesla."+czechMessage InvalidUsernamePass = "Neplatná kombinace uživatelského jména a hesla"+-- TODO+czechMessage i@(IdentifierNotFound _) = englishMessage i+czechMessage Logout = "Odhlásit" -- FIXME by Google Translate+czechMessage LogoutTitle = "Odhlásit" -- FIXME by Google Translate+czechMessage AuthError = "Chyba ověřování" -- FIXME by Google Translate++-- Так как e-mail – это фактическое сокращение словосочетания electronic mail,+-- для русского перевода так же использовано сокращение: эл.почта+russianMessage :: AuthMessage -> Text+russianMessage NoOpenID = "Идентификатор OpenID не найден"+russianMessage LoginOpenID = "Вход с помощью OpenID"+russianMessage LoginGoogle = "Вход с помощью Google"+russianMessage LoginYahoo = "Вход с помощью Yahoo"+russianMessage Email = "Эл.почта"+russianMessage UserName = "Имя пользователя"+russianMessage Password = "Пароль"+russianMessage CurrentPassword = "Старый пароль"+russianMessage Register = "Регистрация"+russianMessage RegisterLong = "Создать учётную запись"+russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."+russianMessage ConfirmationEmailSentTitle = "Письмо для подтверждения отправлено"+russianMessage (ConfirmationEmailSent email) =+ "Письмо для подтверждения было отправлено на адрес " `mappend`+ email `mappend`+ "."+russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."+russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."+russianMessage EmailVerified = "Адрес подтверждён"+russianMessage InvalidKeyTitle = "Неверный ключ подтверждения"+russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным."+russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"+russianMessage BadSetPass = "Чтобы изменить пароль, необходимо выполнить вход"+russianMessage SetPassTitle = "Установить пароль"+russianMessage SetPass = "Установить новый пароль"+russianMessage NewPass = "Новый пароль"+russianMessage ConfirmPass = "Подтверждение пароля"+russianMessage PassMismatch = "Пароли не совпадают, повторите снова"+russianMessage PassUpdated = "Пароль обновлён"+russianMessage Facebook = "Войти с помощью Facebook"+russianMessage LoginViaEmail = "Войти по адресу эл.почты"+russianMessage InvalidLogin = "Неверный логин"+russianMessage NowLoggedIn = "Вход выполнен"+russianMessage LoginTitle = "Войти"+russianMessage PleaseProvideUsername = "Пожалуйста, введите ваше имя пользователя"+russianMessage PleaseProvidePassword = "Пожалуйста, введите ваш пароль"+russianMessage NoIdentifierProvided = "Не указан адрес эл.почты/имя пользователя"+russianMessage InvalidEmailAddress = "Указан неверный адрес эл.почты"+russianMessage PasswordResetTitle = "Сброс пароля"+russianMessage ProvideIdentifier = "Имя пользователя или эл.почта"+russianMessage SendPasswordResetEmail = "Отправить письмо для сброса пароля"+russianMessage PasswordResetPrompt = "Введите адрес эл.почты или ваше имя пользователя ниже, вам будет отправлено письмо для сброса пароля."+russianMessage InvalidUsernamePass = "Неверное сочетание имени пользователя и пароля"+russianMessage (IdentifierNotFound ident) = "Логин не найден: " `mappend` ident+russianMessage Logout = "Выйти"+russianMessage LogoutTitle = "Выйти"+russianMessage AuthError = "Ошибка аутентификации"++dutchMessage :: AuthMessage -> Text+dutchMessage NoOpenID = "Geen OpenID identificator gevonden"+dutchMessage LoginOpenID = "Inloggen via OpenID"+dutchMessage LoginGoogle = "Inloggen via Google"+dutchMessage LoginYahoo = "Inloggen via Yahoo"+dutchMessage Email = "E-mail"+dutchMessage UserName = "Gebruikersnaam"+dutchMessage Password = "Wachtwoord"+dutchMessage CurrentPassword = "Huidig wachtwoord"+dutchMessage Register = "Registreren"+dutchMessage RegisterLong = "Registreer een nieuw account"+dutchMessage EnterEmail = "Voer uw e-mailadres hieronder in, er zal een bevestigings-e-mail naar u worden verzonden."+dutchMessage ConfirmationEmailSentTitle = "Bevestigings-e-mail verzonden"+dutchMessage (ConfirmationEmailSent email) =+ "Een bevestigings-e-mail is verzonden naar " `mappend`+ email `mappend`+ "."+dutchMessage AddressVerified = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"+dutchMessage EmailVerifiedChangePass = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"+dutchMessage EmailVerified = "Adres geverifieerd"+dutchMessage InvalidKeyTitle = "Ongeldig verificatietoken"+dutchMessage InvalidKey = "Dat was helaas een ongeldig verificatietoken."+dutchMessage InvalidEmailPass = "Ongeldige e-mailadres/wachtwoord combinatie"+dutchMessage BadSetPass = "U moet ingelogd zijn om een nieuwe wachtwoord in te stellen"+dutchMessage SetPassTitle = "Wachtwoord instellen"+dutchMessage SetPass = "Een nieuwe wachtwoord instellen"+dutchMessage NewPass = "Nieuw wachtwoord"+dutchMessage ConfirmPass = "Bevestig"+dutchMessage PassMismatch = "Wachtwoorden kwamen niet overeen, probeer het alstublieft nog eens"+dutchMessage PassUpdated = "Wachtwoord geüpdatet"+dutchMessage Facebook = "Inloggen met Facebook"+dutchMessage LoginViaEmail = "Inloggen via e-mail"+dutchMessage InvalidLogin = "Ongeldige inloggegevens"+dutchMessage NowLoggedIn = "U bent nu ingelogd"+dutchMessage LoginTitle = "Inloggen"+dutchMessage PleaseProvideUsername = "Voer alstublieft uw gebruikersnaam in"+dutchMessage PleaseProvidePassword = "Voer alstublieft uw wachtwoord in"+dutchMessage NoIdentifierProvided = "Geen e-mailadres/gebruikersnaam opgegeven"+dutchMessage InvalidEmailAddress = "Ongeldig e-mailadres opgegeven"+dutchMessage PasswordResetTitle = "Wachtwoord wijzigen"+dutchMessage ProvideIdentifier = "E-mailadres of gebruikersnaam"+dutchMessage SendPasswordResetEmail = "Stuur een wachtwoord reset e-mail"+dutchMessage PasswordResetPrompt = "Voer uw e-mailadres of gebruikersnaam hieronder in, er zal een e-mail naar u worden verzonden waarmee u uw wachtwoord kunt wijzigen."+dutchMessage InvalidUsernamePass = "Ongeldige gebruikersnaam/wachtwoord combinatie"+dutchMessage (IdentifierNotFound ident) = "Inloggegevens niet gevonden: " `mappend` ident+dutchMessage Logout = "Uitloggen"+dutchMessage LogoutTitle = "Uitloggen"+dutchMessage AuthError = "Verificatiefout"++croatianMessage :: AuthMessage -> Text+croatianMessage NoOpenID = "Nije pronađen OpenID identifikator"+croatianMessage LoginOpenID = "Prijava uz OpenID"+croatianMessage LoginGoogle = "Prijava uz Google"+croatianMessage LoginYahoo = "Prijava uz Yahoo"+croatianMessage Facebook = "Prijava uz Facebook"+croatianMessage LoginViaEmail = "Prijava putem e-pošte"+croatianMessage Email = "E-pošta"+croatianMessage UserName = "Korisničko ime"+croatianMessage Password = "Lozinka"+croatianMessage CurrentPassword = "Current Password"+croatianMessage Register = "Registracija"+croatianMessage RegisterLong = "Registracija novog računa"+croatianMessage EnterEmail = "Dolje unesite adresu e-pošte, pa ćemo vam poslati e-poruku za potvrdu."+croatianMessage PasswordResetPrompt = "Dolje unesite adresu e-pošte ili korisničko ime, pa ćemo vam poslati e-poruku za potvrdu."+croatianMessage ConfirmationEmailSentTitle = "E-poruka za potvrdu"+croatianMessage (ConfirmationEmailSent email) = "E-poruka za potvrdu poslana je na adresu " <> email <> "."+croatianMessage AddressVerified = "Adresa ovjerena, postavite novu lozinku"+croatianMessage EmailVerifiedChangePass = "Adresa ovjerena, postavite novu lozinku"+croatianMessage EmailVerified = "Adresa ovjerena"+croatianMessage InvalidKeyTitle = "Ključ za ovjeru nije valjan"+croatianMessage InvalidKey = "Nažalost, taj ključ za ovjeru nije valjan."+croatianMessage InvalidEmailPass = "Kombinacija e-pošte i lozinke nije valjana"+croatianMessage InvalidUsernamePass = "Kombinacija korisničkog imena i lozinke nije valjana"+croatianMessage BadSetPass = "Za postavljanje lozinke morate biti prijavljeni"+croatianMessage SetPassTitle = "Postavi lozinku"+croatianMessage SetPass = "Postavite novu lozinku"+croatianMessage NewPass = "Nova lozinka"+croatianMessage ConfirmPass = "Potvrda lozinke"+croatianMessage PassMismatch = "Lozinke se ne podudaraju, pokušajte ponovo"+croatianMessage PassUpdated = "Lozinka ažurirana"+croatianMessage InvalidLogin = "Prijava nije valjana"+croatianMessage NowLoggedIn = "Sada ste prijavljeni u"+croatianMessage LoginTitle = "Prijava"+croatianMessage PleaseProvideUsername = "Unesite korisničko ime"+croatianMessage PleaseProvidePassword = "Unesite lozinku"+croatianMessage NoIdentifierProvided = "Nisu dani e-pošta/korisničko ime"+croatianMessage InvalidEmailAddress = "Dana adresa e-pošte nije valjana"+croatianMessage PasswordResetTitle = "Poništavanje lozinke"+croatianMessage ProvideIdentifier = "E-pošta ili korisničko ime"+croatianMessage SendPasswordResetEmail = "Pošalji e-poruku za poništavanje lozinke"+croatianMessage (IdentifierNotFound ident) = "Korisničko ime/e-pošta nisu pronađeni: " <> ident+croatianMessage Logout = "Odjava"+croatianMessage LogoutTitle = "Odjava"+croatianMessage AuthError = "Pogreška provjere autentičnosti"++danishMessage :: AuthMessage -> Text+danishMessage NoOpenID = "Mangler OpenID identifier"+danishMessage LoginOpenID = "Login med OpenID"+danishMessage LoginGoogle = "Login med Google"+danishMessage LoginYahoo = "Login med Yahoo"+danishMessage Email = "E-mail"+danishMessage UserName = "Brugernavn"+danishMessage Password = "Kodeord"+danishMessage CurrentPassword = "Nuværende kodeord"+danishMessage Register = "Opret"+danishMessage RegisterLong = "Opret en ny konto"+danishMessage EnterEmail = "Indtast din e-mailadresse nedenfor og en bekræftelsesmail vil blive sendt til dig."+danishMessage ConfirmationEmailSentTitle = "Bekræftelsesmail sendt"+danishMessage (ConfirmationEmailSent email) =+ "En bekræftelsesmail er sendt til " `mappend`+ email `mappend`+ "."+danishMessage AddressVerified = "Adresse bekræftet, sæt venligst et nyt kodeord"+danishMessage EmailVerifiedChangePass = "Adresse bekræftet, sæt venligst et nyt kodeord"+danishMessage EmailVerified = "Adresse bekræftet"+danishMessage InvalidKeyTitle = "Ugyldig verifikationsnøgle"+danishMessage InvalidKey = "Beklager, det var en ugyldigt verifikationsnøgle."+danishMessage InvalidEmailPass = "Ugyldigt e-mail/kodeord"+danishMessage BadSetPass = "Du skal være logget ind for at sætte et kodeord"+danishMessage SetPassTitle = "Sæt kodeord"+danishMessage SetPass = "Sæt et nyt kodeord"+danishMessage NewPass = "Nyt kodeord"+danishMessage ConfirmPass = "Bekræft"+danishMessage PassMismatch = "Kodeordne var forskellige, prøv venligst igen"+danishMessage PassUpdated = "Kodeord opdateret"+danishMessage Facebook = "Login med Facebook"+danishMessage LoginViaEmail = "Login med e-mail"+danishMessage InvalidLogin = "Ugyldigt login"+danishMessage NowLoggedIn = "Du er nu logget ind"+danishMessage LoginTitle = "Log ind"+danishMessage PleaseProvideUsername = "Indtast venligst dit brugernavn"+danishMessage PleaseProvidePassword = "Indtasy venligst dit kodeord"+danishMessage NoIdentifierProvided = "Mangler e-mail/username"+danishMessage InvalidEmailAddress = "Ugyldig e-mailadresse indtastet"+danishMessage PasswordResetTitle = "Nulstilning af kodeord"+danishMessage ProvideIdentifier = "E-mail eller brugernavn"+danishMessage SendPasswordResetEmail = "Send kodeordsnulstillingsmail"+danishMessage PasswordResetPrompt = "Indtast din e-mailadresse eller dit brugernavn nedenfor, så bliver en kodeordsnulstilningsmail sendt til dig."+danishMessage InvalidUsernamePass = "Ugyldigt brugernavn/kodeord"+danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend` ident+danishMessage Logout = "Log ud"+danishMessage LogoutTitle = "Log ud"+danishMessage AuthError = "Fejl ved bekræftelse af identitet"++koreanMessage :: AuthMessage -> Text+koreanMessage NoOpenID = "OpenID ID가 없습니다"+koreanMessage LoginOpenID = "OpenID로 로그인"+koreanMessage LoginGoogle = "Google로 로그인"+koreanMessage LoginYahoo = "Yahoo로 로그인"+koreanMessage Email = "이메일"+koreanMessage UserName = "사용자 이름"+koreanMessage Password = "비밀번호"+koreanMessage CurrentPassword = "현재 비밀번호"+koreanMessage Register = "등록"+koreanMessage RegisterLong = "새 계정 등록"+koreanMessage EnterEmail = "이메일 주소를 아래에 입력하시면 확인 이메일이 발송됩니다."+koreanMessage ConfirmationEmailSentTitle = "확인 이메일을 보냈습니다"+koreanMessage (ConfirmationEmailSent email) =+ "확인 이메일을 " `mappend`+ email `mappend`+ "에 보냈습니다."+koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."+koreanMessage EmailVerifiedChangePass = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."+koreanMessage EmailVerified = "주소가 인증되었습니다"+koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다"+koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다."+koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"+koreanMessage BadSetPass = "비밀번호를 설정하기 위해서는 로그인해야 합니다"+koreanMessage SetPassTitle = "비밀번호 설정"+koreanMessage SetPass = "새 비밀번호 설정"+koreanMessage NewPass = "새 비밀번호"+koreanMessage ConfirmPass = "확인"+koreanMessage PassMismatch = "비밀번호가 맞지 않습니다. 다시 시도해주세요."+koreanMessage PassUpdated = "비밀번호가 업데이트 되었습니다"+koreanMessage Facebook = "Facebook으로 로그인"+koreanMessage LoginViaEmail = "이메일로"+koreanMessage InvalidLogin = "잘못된 로그인입니다"+koreanMessage NowLoggedIn = "로그인했습니다"+koreanMessage LoginTitle = "로그인"+koreanMessage PleaseProvideUsername = "사용자 이름을 입력하세요"+koreanMessage PleaseProvidePassword = "비밀번호를 입력하세요"+koreanMessage NoIdentifierProvided = "이메일 주소나 사용자 이름이 입력되어 있지 않습니다"+koreanMessage InvalidEmailAddress = "이메일 주소가 잘못되었습니다"+koreanMessage PasswordResetTitle = "비밀번호 변경"+koreanMessage ProvideIdentifier = "이메일 주소나 사용자 이름"+koreanMessage SendPasswordResetEmail = "비밀번호 재설정 이메일 보내기"+koreanMessage PasswordResetPrompt = "이메일 주소나 사용자 이름을 아래에 입력하시면 비밀번호 재설정 이메일이 발송됩니다."+koreanMessage InvalidUsernamePass = "사용자 이름이나 비밀번호가 잘못되었습니다"+koreanMessage (IdentifierNotFound ident) = ident `mappend` "는 등록되어 있지 않습니다"+koreanMessage Logout = "로그아웃"+koreanMessage LogoutTitle = "로그아웃"+koreanMessage AuthError = "인증오류"++-- | Romanian translation+--+-- @since 1.6.11.3+romanianMessage :: AuthMessage -> Text+romanianMessage NoOpenID = "Identificatorul OpenID nu a fost găsit"+romanianMessage LoginOpenID = "Conectați-vă cu OpenID"+romanianMessage LoginGoogle = "Conectați-vă cu Google"+romanianMessage LoginYahoo = "Conectați-vă cu Yahoo"+romanianMessage Email = "E-mail"+romanianMessage UserName = "Nume de utilizator"+romanianMessage Password = "Parolă"+romanianMessage CurrentPassword = "Parola curentă"+romanianMessage Register = "Înregistrează-te"+romanianMessage RegisterLong = "Înregistrați un cont nou"+romanianMessage EnterEmail = "Introduceți adresa dvs. de e-mail pentru a primi un e-mail de confirmare."+romanianMessage ConfirmationEmailSentTitle = "Un mesaj de confirmare a fost trimis la adresa dvs. de e-mail"+romanianMessage (ConfirmationEmailSent email) =+ "Un mesaj de confirmare a fost trimis la " `mappend` email `mappend` "."+romanianMessage AddressVerified = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă"+romanianMessage EmailVerifiedChangePass = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă"+romanianMessage EmailVerified = "Adresa de e-mail a fost verificată"+romanianMessage InvalidKeyTitle = "Cheie de verificare nevalidă"+romanianMessage InvalidKey = "Cheie de verificare nevalidă."+romanianMessage InvalidEmailPass = "Nume de utilizator și/sau parolă incorect(ă)"+romanianMessage BadSetPass = "Trebuie să fiți autentificat pentru a seta parola"+romanianMessage SetPassTitle = "Setarea parolei"+romanianMessage SetPass = "Setează parolă nouă"+romanianMessage NewPass = "Parolă nouă"+romanianMessage ConfirmPass = "Confirmă"+romanianMessage PassMismatch = "Parolele nu se potrivesc, vă rugăm să încercați din nou"+romanianMessage PassUpdated = "Parola a fost actualizată"+romanianMessage Facebook = "Conectați-vă cu Facebook"+romanianMessage LoginViaEmail = "Conectați-vă cu contul de e-mail"+romanianMessage InvalidLogin = "Nume de utilizator incorect"+romanianMessage NowLoggedIn = "Felicitări. Acum sunteți autentificat."+romanianMessage LoginTitle = "Autentificare"+romanianMessage PleaseProvideUsername = "Introduceți, vă rog, numele dvs. de utilizator"+romanianMessage PleaseProvidePassword = "Introduceți, vă rog, parola dvs."+romanianMessage NoIdentifierProvided = "Adresa de e-mail sau numele de utilizator nu sunt furnizate."+romanianMessage InvalidEmailAddress = "Adresă de e-mail nevalidă"+romanianMessage PasswordResetTitle = "Resetarea parolei"+romanianMessage ProvideIdentifier = "Adresă de e-mail sau nume de utilizator"+romanianMessage SendPasswordResetEmail = "Trimite un e-mail pentru resetarea parolei"+romanianMessage PasswordResetPrompt =+ "Introduceți adresa dvs. de e-mail sau numele de utilizator pentru a primi un e-mail de resetare a parolei."+romanianMessage InvalidUsernamePass = "Nume de utilizator și/sau parolă incorect(ă)"+romanianMessage (IdentifierNotFound ident) = "Numele de utilizator nu a fost găsit: " `mappend` ident+romanianMessage Logout = "Deconectați-vă"+romanianMessage LogoutTitle = "Deconectare"+romanianMessage AuthError = "Eroare de autentificare"
Yesod/Auth/OpenId.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+ module Yesod.Auth.OpenId ( authOpenId , forwardUrl@@ -14,36 +17,32 @@ import qualified Web.Authenticate.OpenId as OpenId import Yesod.Form-import Yesod.Handler-import Yesod.Widget (toWidget, whamlet)-import Yesod.Request-import Text.Cassius (cassius)-#if MIN_VERSION_blaze_html(0, 5, 0)-import Text.Blaze.Html (toHtml)-#else-import Text.Blaze (toHtml)-#endif+import Yesod.Core import Data.Text (Text, isPrefixOf) import qualified Yesod.Auth.Message as Msg-import Control.Exception.Lifted (SomeException, try)+import UnliftIO.Exception (tryAny) import Data.Maybe (fromMaybe)+import qualified Data.Text as T forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] data IdentifierType = Claimed | OPLocal -authOpenId :: YesodAuth m+authOpenId :: YesodAuth master => IdentifierType -> [(Text, Text)] -- ^ extension fields- -> AuthPlugin m+ -> AuthPlugin master authOpenId idType extensionFields = AuthPlugin "openid" dispatch login where complete = PluginR "openid" ["complete"]++ name :: Text name = "openid_identifier"+ login tm = do- ident <- lift newIdent+ ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the -- code, but it shouldn't be necessary let y :: a -> [(Text, Text)] -> Text@@ -55,9 +54,6 @@ [whamlet| $newline never <form method="get" action="@{tm forwardUrl}">- <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">- <button .openid-google>_{Msg.LoginGoogle}-<form method="get" action="@{tm forwardUrl}"> <input type="hidden" name="openid_identifier" value="http://me.yahoo.com"> <button .openid-yahoo>_{Msg.LoginYahoo} <form method="get" action="@{tm forwardUrl}">@@ -65,24 +61,21 @@ <input id="#{ident}" type="text" name="#{name}" value="http://"> <input type="submit" value="_{Msg.LoginOpenID}"> |]++ dispatch :: Text -> [Text] -> AuthHandler master TypedContent dispatch "GET" ["forward"] = do roid <- runInputGet $ iopt textField name case roid of Just oid -> do+ tm <- getRouteToParent render <- getUrlRender- toMaster <- getRouteToMaster- let complete' = render $ toMaster complete- master <- getYesod- eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)+ let complete' = render $ tm complete+ manager <- authHttpManager+ eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager case eres of- Left err -> do- setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR+ Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err Right x -> redirect x- Nothing -> do- toMaster <- getRouteToMaster- setMessageI Msg.NoOpenID- redirect $ toMaster LoginR+ Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest@@ -93,29 +86,29 @@ completeHelper idType posts dispatch _ _ = notFound -completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do- master <- getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- toMaster <- getRouteToMaster- let onFailure err = do- setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR- let onSuccess oir = do- let claimed =- case OpenId.oirClaimed oir of- Nothing -> id- Just (OpenId.Identifier i') -> ((claimedKey, i'):)- oplocal =- case OpenId.oirOpLocal oir of- OpenId.Identifier i' -> ((opLocalKey, i'):)- gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'- i = OpenId.identifier $- case idType of- OPLocal -> OpenId.oirOpLocal oir- Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- setCreds True $ Creds "openid" i gets''- either onFailure onSuccess eres+ manager <- authHttpManager+ eres <- tryAny $ OpenId.authenticateClaimed gets' manager+ either onFailure onSuccess eres+ where+ onFailure err = do+ tm <- getRouteToParent+ loginErrorMessage (tm LoginR) $ T.pack $ show err+ onSuccess oir = do+ let claimed =+ case OpenId.oirClaimed oir of+ Nothing -> id+ Just (OpenId.Identifier i') -> ((claimedKey, i'):)+ oplocal =+ case OpenId.oirOpLocal oir of+ OpenId.Identifier i' -> ((opLocalKey, i'):)+ gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'+ i = OpenId.identifier $+ case idType of+ OPLocal -> OpenId.oirOpLocal oir+ Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir+ setCredsRedirect $ Creds "openid" i gets'' -- | The main identifier provided by the OpenID authentication plugin is the -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
+ Yesod/Auth/Routes.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.Auth.Routes where++import Yesod.Core+import Data.Text (Text)++data Auth = Auth++mkYesodSubData "Auth" [parseRoutes|+/check CheckR GET+/login LoginR GET+/logout LogoutR GET POST+/page/#Text/*Texts PluginR+|]
Yesod/Auth/Rpxnow.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+ module Yesod.Auth.Rpxnow ( authRpxnow ) where@@ -10,43 +12,38 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import Control.Monad (mplus) -import Yesod.Handler-import Yesod.Widget-import Yesod.Request-import Text.Hamlet (hamlet)+import Yesod.Core import Data.Text (pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Control.Arrow ((***)) import Network.HTTP.Types (renderQuery) -authRpxnow :: YesodAuth m+authRpxnow :: YesodAuth master => String -- ^ app name -> String -- ^ key- -> AuthPlugin m+ -> AuthPlugin master authRpxnow app apiKey = AuthPlugin "rpxnow" dispatch login where- login ::- forall sub master.- ToWidget sub master (GWidget sub master ())- => (Route Auth -> Route master) -> GWidget sub master () login tm = do- render <- lift getUrlRender+ render <- getUrlRender let queryString = decodeUtf8With lenientDecode $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])] toWidget [hamlet| $newline never <iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> |]++ dispatch :: a -> [b] -> AuthHandler master TypedContent dispatch _ [] = do token1 <- lookupGetParams "token" token2 <- lookupPostParams "token" token <- case token1 ++ token2 of [] -> invalidArgs ["token: Value not supplied"] x:_ -> return $ unpack x- master <- getYesod- Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)+ manager <- authHttpManager+ Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager let creds = Creds "rpxnow" ident $ maybe id (\x -> (:) ("verifiedEmail", x))@@ -54,7 +51,7 @@ $ maybe id (\x -> (:) ("displayName", x)) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) []- setCreds True creds+ setCredsRedirect creds dispatch _ _ = notFound -- | Get some form of a display name.
+ Yesod/Auth/Util/PasswordStore.hs view
@@ -0,0 +1,457 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011,+-- and released under a BSD-style licence.+--+-- Securely store hashed, salted passwords. If you need to store and verify+-- passwords, there are many wrong ways to do it, most of them all too+-- common. Some people store users' passwords in plain text. Then, when an+-- attacker manages to get their hands on this file, they have the passwords for+-- every user's account. One step up, but still wrong, is to simply hash all+-- passwords with SHA1 or something. This is vulnerable to rainbow table and+-- dictionary attacks. One step up from that is to hash the password along with+-- a unique salt value. This is vulnerable to dictionary attacks, since guessing+-- a password is very fast. The right thing to do is to use a slow hash+-- function, to add some small but significant delay, that will be negligible+-- for legitimate users but prohibitively expensive for someone trying to guess+-- passwords by brute force. That is what this library does. It iterates a+-- SHA256 hash, with a random salt, a few thousand times. This scheme is known+-- as PBKDF1, and is generally considered secure; there is nothing innovative+-- happening here.+--+-- The API here is very simple. What you store are called /password hashes/.+-- They are strings (technically, ByteStrings) that look like this:+--+-- > "sha256|14|jEWU94phx4QzNyH94Qp4CQ==|5GEw+jxP/4WLgzt9VS3Ee3nhqBlDsrKiB+rq7JfMckU="+--+-- Each password hash shows the algorithm, the strength (more on that later),+-- the salt, and the hashed-and-salted password. You store these on your server,+-- in a database, for when you need to verify a password. You make a password+-- hash with the 'makePassword' function. Here's an example:+--+-- > >>> makePassword "hunter2" 14+-- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="+--+-- This will hash the password @\"hunter2\"@, with strength 14, which is a good+-- default value. The strength here determines how long the hashing will+-- take. When doing the hashing, we iterate the SHA256 hash function+-- @2^strength@ times, so increasing the strength by 1 makes the hashing take+-- twice as long. When computers get faster, you can bump up the strength a+-- little bit to compensate. You can strengthen existing password hashes with+-- the 'strengthenPassword' function. Note that 'makePassword' needs to generate+-- random numbers, so its return type is 'IO' 'ByteString'. If you want to avoid+-- the 'IO' monad, you can generate your own salt and pass it to+-- 'makePasswordSalt'.+--+-- Your strength value should not be less than 12, and 14 is a good default+-- value at the time of this writing, in 2013.+--+-- Once you've got your password hashes, the second big thing you need to do+-- with them is verify passwords against them. When a user gives you a password,+-- you compare it with a password hash using the 'verifyPassword' function:+--+-- > >>> verifyPassword "wrong guess" passwordHash+-- > False+-- > >>> verifyPassword "hunter2" passwordHash+-- > True+--+-- These two functions are really all you need. If you want to make existing+-- password hashes stronger, you can use 'strengthenPassword'. Just pass it an+-- existing password hash and a new strength value, and it will return a new+-- password hash with that strength value, which will match the same password as+-- the old password hash.+--+-- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact+-- iteration count. This does not have a significant effect on security, but can+-- be handy for compatibility with other code.+--+-- @since 1.4.18++module Yesod.Auth.Util.PasswordStore (++ -- * Algorithms+ pbkdf1, -- :: ByteString -> Salt -> Int -> ByteString+ pbkdf2, -- :: ByteString -> Salt -> Int -> ByteString++ -- * Registering and verifying passwords+ makePassword, -- :: ByteString -> Int -> IO ByteString+ makePasswordWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->+ -- ByteString -> Int -> IO ByteString+ makePasswordSalt, -- :: ByteString -> ByteString -> Int -> ByteString+ makePasswordSaltWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->+ -- ByteString -> Salt -> Int -> ByteString+ verifyPassword, -- :: ByteString -> ByteString -> Bool+ verifyPasswordWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->+ -- (Int -> Int) -> ByteString -> ByteString -> Bool++ -- * Updating password hash strength+ strengthenPassword, -- :: ByteString -> Int -> ByteString+ passwordStrength, -- :: ByteString -> Int++ -- * Utilities+ Salt,+ isPasswordFormatValid, -- :: ByteString -> Bool+ genSaltIO, -- :: IO Salt+ genSaltRandom, -- :: (RandomGen b) => b -> (Salt, b)+ makeSalt, -- :: ByteString -> Salt+ exportSalt, -- :: Salt -> ByteString+ importSalt -- :: ByteString -> Salt+ ) where++import qualified Crypto.MAC.HMAC as CH+import qualified Crypto.Hash as CH+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Binary as Binary+import Control.Monad+import Control.Monad.ST+import Data.STRef+import Data.Bits+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Base64 (encode, decodeLenient)+import System.IO+import System.Random+import Data.Maybe+import qualified Control.Exception+import Data.ByteArray (convert)++---------------------+-- Cryptographic base+---------------------++-- | PBKDF1 key-derivation function. Takes a password, a 'Salt', and a number of+-- iterations. The number of iterations should be at least 1000, and probably+-- more. 5000 is a reasonable number, computing almost instantaneously. This+-- will give a 32-byte 'ByteString' as output. Both the salt and this 32-byte+-- key should be stored in the password file. When a user wishes to authenticate+-- a password, just pass it and the salt to this function, and see if the output+-- matches.+--+-- @since 1.4.18+--+pbkdf1 :: ByteString -> Salt -> Int -> ByteString+pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)+ where+ first_hash =+ convert $+ ((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256)+++-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0+-- or more. If the number of rounds specified is 0, the ByteString will be+-- returned unmodified.+hashRounds :: ByteString -> Int -> ByteString+hashRounds (!bs) 0 = bs+hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1)++-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.+hmacSHA256 :: ByteString+ -- ^ The secret (the salt)+ -> ByteString+ -- ^ The clear-text message+ -> ByteString+ -- ^ The encoded message+hmacSHA256 secret msg =+ convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)++-- | PBKDF2 key-derivation function.+-- For details see @http://tools.ietf.org/html/rfc2898@.+-- @32@ is the most common digest size for @SHA256@, and is+-- what the algorithm internally uses.+-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.+--+-- @since 1.4.18+--+pbkdf2 :: ByteString -> Salt -> Int -> ByteString+pbkdf2 password (SaltBS salt) c =+ let hLen = 32+ dkLen = hLen in go hLen dkLen+ where+ go hLen dkLen | dkLen > (2 ^ (32 :: Int) - 1) * hLen = error "Derived key too long."+ | otherwise =+ let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)+ !r = dkLen - (l - 1) * hLen+ chunks = [f i | i <- [1 .. l]]+ in (B.concat . init $ chunks) `B.append` B.take r (last chunks)++ -- The @f@ function, as defined in the spec.+ -- It calls 'u' under the hood.+ f :: Int -> ByteString+ f i = let !u1 = hmacSHA256 password (salt `B.append` int i)+ -- Using the ST Monad, for maximum performance.+ in runST $ do+ u <- newSTRef u1+ accum <- newSTRef u1+ forM_ [2 .. c] $ \_ -> do+ modifySTRef' u (hmacSHA256 password)+ currentU <- readSTRef u+ modifySTRef' accum (`xor'` currentU)+ readSTRef accum++ -- int(i), as defined in the spec.+ int :: Int -> ByteString+ int i = let str = BL.unpack . Binary.encode $ i+ in BS.pack $ drop (length str - 4) str++ -- | A convenience function to XOR two 'ByteString' together.+ xor' :: ByteString -> ByteString -> ByteString+ xor' !b1 !b2 = BS.pack $ BS.zipWith xor b1 b2++-- | 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'.+--+-- @since 1.4.18+--+genSaltIO :: IO Salt+genSaltIO =+ Control.Exception.catch genSaltDevURandom def+ where+ def :: IOError -> IO Salt+ def _ = genSaltSysRandom++-- | Generate a 'Salt' from @\/dev\/urandom@.+genSaltDevURandom :: IO Salt+genSaltDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do+ rawSalt <- B.hGet h 16+ return $ makeSalt rawSalt++-- | Generate a 'Salt' from 'System.Random'.+genSaltSysRandom :: IO Salt+genSaltSysRandom = randomChars >>= return . makeSalt . B.pack+ where randomChars = sequence $ replicate 16 $ randomRIO ('\NUL', '\255')++-----------------------+-- Password hash format+-----------------------++-- Format: "sha256|strength|salt|hash", where strength is an unsigned int, salt+-- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash+-- value.++-- | Try to parse a password hash.+readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)+readPwHash pw+ | ["sha256", strBS, salt, hash] <- broken+ , B.length hash == 44 =+ (\(strength, _) -> (strength, SaltBS salt, hash))+ <$> B.readInt strBS+ | otherwise = Nothing+ where+ broken = B.split '|' pw+++-- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where+-- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded+-- 'ByteString's.+writePwHash :: (Int, Salt, ByteString) -> ByteString+writePwHash (strength, SaltBS salt, hash) =+ B.intercalate "|" ["sha256", B.pack (show strength), salt, hash]++-----------------+-- High level API+-----------------++-- | Hash a password with a given strength (14 is a good default). The output of+-- this function can be written directly to a password file or+-- database. Generates a salt using high-quality randomness from+-- @\/dev\/urandom@ or (if that is not available, for example on Windows)+-- 'System.Random', which is included in the hashed output.+--+-- @since 1.4.18+--+makePassword :: ByteString -> Int -> IO ByteString+makePassword = makePasswordWith pbkdf1++-- | A generic version of 'makePassword', which allow the user+-- to choose the algorithm to use.+--+-- >>> makePasswordWith pbkdf1 "password" 14+--+-- @since 1.4.18+--+makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)+ -- ^ The algorithm to use (e.g. pbkdf1)+ -> ByteString+ -- ^ The password to encrypt+ -> Int+ -- ^ log2 of the number of iterations+ -> IO ByteString+makePasswordWith algorithm password strength = do+ salt <- genSaltIO+ return $ makePasswordSaltWith algorithm (2 ^) password salt strength++-- | A generic version of 'makePasswordSalt', meant to give the user+-- the maximum control over the generation parameters.+-- Note that, unlike 'makePasswordWith', this function takes the @raw@+-- number of iterations. This means the user will need to specify a+-- sensible value, typically @10000@ or @20000@.+--+-- @since 1.4.18+--+makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)+ -- ^ A function modeling an algorithm (e.g. 'pbkdf1')+ -> (Int -> Int)+ -- ^ A function to modify the strength+ -> ByteString+ -- ^ A password, given as clear text+ -> Salt+ -- ^ A hash 'Salt'+ -> Int+ -- ^ The password strength (e.g. @10000, 20000, etc.@)+ -> ByteString+makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash (strength, salt, hash)+ where hash = encode $ algorithm pwd salt (strengthModifier strength)++-- | Hash a password with a given strength (14 is a good default), using a given+-- salt. The output of this function can be written directly to a password file+-- or database. Example:+--+-- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14+-- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="+--+-- @since 1.4.18+--+makePasswordSalt :: ByteString -> Salt -> Int -> ByteString+makePasswordSalt = makePasswordSaltWith pbkdf1 (2 ^)++-- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies+-- the password @userInput@ given by the user against the stored password+-- hash @pwHash@, with the hashing algorithm @algorithm@. Returns 'True' if the+-- given password is correct, and 'False' if it is not.+-- This function allows the programmer to specify the algorithm to use,+-- e.g. 'pbkdf1' or 'pbkdf2'.+-- Note: If you want to verify a password previously generated with+-- 'makePasswordSaltWith', but without modifying the number of iterations,+-- you can do:+--+-- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."+-- > True+--+-- @since 1.4.18+--+verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)+ -- ^ A function modeling an algorithm (e.g. pbkdf1)+ -> (Int -> Int)+ -- ^ A function to modify the strength+ -> ByteString+ -- ^ User password+ -> ByteString+ -- ^ The generated hash (e.g. sha256|14...)+ -> Bool+verifyPasswordWith algorithm strengthModifier userInput pwHash =+ case readPwHash pwHash of+ Nothing -> False+ Just (strength, salt, goodHash) ->+ encode (algorithm userInput salt (strengthModifier strength)) == goodHash++-- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.+--+-- @since 1.4.18+--+verifyPassword :: ByteString -> ByteString -> Bool+verifyPassword = verifyPasswordWith pbkdf1 (2 ^)++-- | Try to strengthen a password hash, by hashing it some more+-- times. @'strengthenPassword' pwHash new_strength@ will return a new password+-- hash with strength at least @new_strength@. If the password hash already has+-- strength greater than or equal to @new_strength@, then it is returned+-- unmodified. If the password hash is invalid and does not parse, it will be+-- returned without comment.+--+-- This function can be used to periodically update your password database when+-- computers get faster, in order to keep up with Moore's law. This isn't hugely+-- important, but it's a good idea.+--+-- @since 1.4.18+--+strengthenPassword :: ByteString -> Int -> ByteString+strengthenPassword pwHash newstr =+ case readPwHash pwHash of+ Nothing -> pwHash+ Just (oldstr, salt, hashB64) ->+ if oldstr < newstr then+ writePwHash (newstr, salt, newHash)+ else+ pwHash+ where newHash = encode $ hashRounds hash extraRounds+ extraRounds = (2 ^ newstr) - (2 ^ oldstr)+ hash = decodeLenient hashB64++-- | Return the strength of a password hash.+--+-- @since 1.4.18+--+passwordStrength :: ByteString -> Int+passwordStrength pwHash = case readPwHash pwHash of+ Nothing -> 0+ Just (strength, _, _) -> strength++------------+-- Utilities+------------++-- | A salt is a unique random value which is stored as part of the password+-- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you+-- really know what you're doing, you can create them from your own ByteString+-- values with 'makeSalt'.+--+-- @since 1.4.18+--+newtype Salt = SaltBS ByteString+ deriving (Show, Eq, Ord)++-- | Create a 'Salt' from a 'ByteString'. The input must be at least 8+-- characters, and can contain arbitrary bytes. Most users will not need to use+-- this function.+--+-- @since 1.4.18+--+makeSalt :: ByteString -> Salt+makeSalt = SaltBS . encode . check_length+ where check_length salt | B.length salt < 8 =+ error "Salt too short. Minimum length is 8 characters."+ | otherwise = salt++-- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be+-- base64-encoded. Most users will not need to use this function.+--+-- @since 1.4.18+--+exportSalt :: Salt -> ByteString+exportSalt (SaltBS bs) = bs++-- | Convert a raw 'ByteString' into a 'Salt'.+-- Use this function with caution, since using a weak salt will result in a+-- weak password.+--+-- @since 1.4.18+--+importSalt :: ByteString -> Salt+importSalt = SaltBS++-- | Is the format of a password hash valid? Attempts to parse a given password+-- hash. Returns 'True' if it parses correctly, and 'False' otherwise.+--+-- @since 1.4.18+--+isPasswordFormatValid :: ByteString -> Bool+isPasswordFormatValid = isJust . readPwHash++-- | Generate a 'Salt' with 128 bits of data taken from a given random number+-- generator. Returns the salt and the updated random number generator. This is+-- meant to be used with 'makePasswordSalt' by people who would prefer to either+-- use their own random number generator or avoid the 'IO' monad.+--+-- @since 1.4.18+--+genSaltRandom :: (RandomGen b) => b -> (Salt, b)+genSaltRandom gen = (salt, newgen)+ where rands _ 0 = []+ rands g n = (a, g') : rands g' (n-1 :: Int)+ where (a, g') = randomR ('\NUL', '\255') g+ salt = makeSalt $ B.pack $ map fst (rands gen 16)+ newgen = snd $ last (rands gen 16)
yesod-auth.cabal view
@@ -1,5 +1,6 @@+cabal-version: >=1.10 name: yesod-auth-version: 1.1.7+version: 1.6.12.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -7,54 +8,73 @@ synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable-cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/-description: Authentication for Yesod.+description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth> extra-source-files: persona_sign_in_blue.png+ README.md+ ChangeLog.md +flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ library- build-depends: base >= 4 && < 5- , authenticate >= 1.3+ default-language: Haskell2010+ build-depends: base >= 4.11 && < 5+ , aeson >= 0.7+ , attoparsec-aeson >= 2.1+ , authenticate >= 1.3.4+ , base16-bytestring+ , base64-bytestring+ , binary+ , blaze-builder+ , blaze-html >= 0.5+ , blaze-markup >= 0.5.1 , bytestring >= 0.9.1.4- , yesod-core >= 1.1 && < 1.2- , wai >= 1.3- , template-haskell- , pureMD5 >= 2.0+ , conduit >= 1.3+ , conduit-extra+ , containers+ , crypton+ , data-default+ , email-validate >= 1.0+ , file-embed+ , http-client >= 0.5+ , http-client-tls+ , http-conduit >= 2.1+ , http-types+ , memory+ , nonce >= 1.0.2 && < 1.1+ , persistent >= 2.8 , random >= 1.0.0.2+ , safe+ , shakespeare+ , template-haskell , text >= 0.7- , mime-mail >= 0.3- , yesod-persistent >= 1.1- , hamlet >= 1.1 && < 1.2- , shakespeare-css >= 1.0 && < 1.1- , shakespeare-js >= 1.0.2 && < 1.2- , yesod-json >= 1.1 && < 1.2- , containers- , unordered-containers- , yesod-form >= 1.1 && < 1.3+ , time , transformers >= 0.2.2- , persistent >= 1.0 && < 1.2- , persistent-template >= 1.0 && < 1.2- , SHA >= 1.4.1.3- , http-conduit >= 1.5- , aeson >= 0.5- , pwstore-fast >= 2.2- , lifted-base >= 0.1- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , network- , http-types- , file-embed+ , unliftio+ , unliftio-core+ , unordered-containers+ , wai >= 1.4+ , yesod-core >= 1.6 && < 1.8+ , yesod-form >= 1.6 && < 1.8+ , yesod-persistent >= 1.6 + if flag(network-uri)+ build-depends: network-uri >= 2.6+ exposed-modules: Yesod.Auth Yesod.Auth.BrowserId Yesod.Auth.Dummy Yesod.Auth.Email Yesod.Auth.OpenId Yesod.Auth.Rpxnow- Yesod.Auth.HashDB Yesod.Auth.Message- Yesod.Auth.GoogleEmail+ Yesod.Auth.GoogleEmail2+ Yesod.Auth.Hardcoded+ Yesod.Auth.Util.PasswordStore+ other-modules: Yesod.Auth.Routes ghc-options: -Wall source-repository head