yesod-auth 1.2.7.1 → 1.6.12.1
raw patch · 16 files changed
Files
- ChangeLog.md +240/−0
- README.md +12/−0
- Yesod/Auth.hs +371/−192
- Yesod/Auth/BrowserId.hs +21/−13
- Yesod/Auth/Dummy.hs +57/−10
- Yesod/Auth/Email.hs +730/−259
- Yesod/Auth/GoogleEmail.hs +0/−87
- Yesod/Auth/GoogleEmail2.hs +616/−0
- Yesod/Auth/Hardcoded.hs +198/−0
- Yesod/Auth/HashDB.hs +0/−278
- Yesod/Auth/Message.hs +432/−50
- Yesod/Auth/OpenId.hs +22/−22
- Yesod/Auth/Routes.hs +6/−3
- Yesod/Auth/Rpxnow.hs +11/−8
- Yesod/Auth/Util/PasswordStore.hs +457/−0
- yesod-auth.cabal +50/−38
+ 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,14 +1,18 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# 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@@ -17,42 +21,49 @@ , AuthPlugin (..) , getAuth , YesodAuth (..)- , YesodAuthPersist- , AuthEntity+ , 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.Trans.Maybe import Yesod.Auth.Routes-import Data.Aeson 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 Data.Monoid (Endo)-import Network.HTTP.Conduit (Manager)+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@@ -61,21 +72,31 @@ import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception)-import Network.HTTP.Types (unauthorized401)-import Control.Monad.Trans.Resource (MonadResourceBase)+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 AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a+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] -> AuthHandler master ()- , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()+ , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent+ , apLogin :: (Route Auth -> Route master) -> WidgetFor master () } getAuth :: a -> Auth@@ -86,14 +107,14 @@ { 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 :: WidgetT master IO () -> HandlerT master IO Html- authLayout = defaultLayout+ authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html+ authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists.@@ -103,20 +124,53 @@ -- 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 -> HandlerT master IO (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.+ --+ -- 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 = do- tp <- getRouteToParent- lift $ authLayout $ do- setTitleI Msg.LoginTitle- master <- getYesod- mapM_ (flip apLogin tp) (authPlugins master)+ loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package. renderAuthMessage :: master@@ -130,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+ authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager+ authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls- -- @setMessageI NowLoggedIn@.- onLogin :: HandlerT master IO ()- 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 :: HandlerT master IO ()+ onLogout :: (MonadHandler m, master ~ HandlerSite m) => m () onLogout = return () -- | Retrieves user credentials, if user is authenticated.@@ -153,169 +215,230 @@ -- especially useful for creating an API to be accessed via some means -- other than a browser. --- -- Since 1.2.0- maybeAuthId :: HandlerT master IO (Maybe (AuthId master))+ -- @since 1.2.0+ maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master)) default maybeAuthId- :: ( YesodAuth master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val- , b ~ YesodPersistBackend master- , Key val ~ AuthId master- , PersistStore (b (HandlerT master IO))- , PersistEntity val- , YesodPersist master- , Typeable val- )- => HandlerT master IO (Maybe (AuthId master))+ :: (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- -- @setMessage@ and redirects to @dest@.- onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html+ -- @addMessage@ with "error" as status and redirects to @dest@.+ onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html onErrorHtml dest msg = do- setMessage $ toHtml msg+ addMessage "error" $ toHtml msg fmap asHtml $ redirect dest- where- asHtml :: Html -> Html- asHtml = id + -- | 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+-- @since 1.2.3 credsKey :: Text credsKey = "_ID" -- | Retrieves user credentials from the session, if user is authenticated. -- -- This function does /not/ confirm that the credentials are valid, see--- 'maybeAuthIdRaw' for more information.+-- '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+-- @since 1.1.2 defaultMaybeAuthId- :: ( YesodAuth master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val- , b ~ YesodPersistBackend master- , Key val ~ AuthId master- , PersistStore (b (HandlerT master IO))- , PersistEntity val- , YesodPersist master- , Typeable val- ) => HandlerT master IO (Maybe (AuthId master))-defaultMaybeAuthId = do- ms <- lookupSession credsKey- case ms of- Nothing -> return Nothing- Just s ->- case fromPathPiece s of- Nothing -> return Nothing- Just aid -> fmap (fmap entityKey) $ cachedAuth aid+ :: (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 -cachedAuth :: ( YesodAuth master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val- , b ~ YesodPersistBackend master- , Key val ~ AuthId master- , PersistStore (b (HandlerT master IO))- , PersistEntity val- , YesodPersist master- , Typeable val- ) => AuthId master -> HandlerT master IO (Maybe (Entity val))-cachedAuth aid = runMaybeT $ do- a <- MaybeT $ fmap unCachedMaybeAuth- $ cached- $ fmap CachedMaybeAuth- $ runDB- $ get aid- return $ Entity aid a+cachedAuth+ :: ( MonadHandler m+ , YesodAuthPersist master+ , Typeable (AuthEntity master)+ , HandlerSite m ~ master+ )+ => AuthId master+ -> m (Maybe (AuthEntity master))+cachedAuth+ = fmap unCachedMaybeAuth+ . cached+ . fmap CachedMaybeAuth+ . getAuthEntity -loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)- => Route child- -> AuthMessage- -> HandlerT child (HandlerT master m) a+-- | 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- lift $ loginErrorMessageMasterI (toParent dest) msg+ loginErrorMessageMasterI (toParent dest) msg -loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)- => Route master- -> AuthMessage- -> HandlerT master m a+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 :: (YesodAuth master, MonadResourceBase m)- => Route master+loginErrorMessage+ :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Route (HandlerSite m) -> Text- -> HandlerT master m a-loginErrorMessage dest msg =- sendResponseStatus unauthorized401 =<< (- selectRep $ do- provideRep $ do- onErrorHtml dest msg- provideJsonMessage msg- )+ -> 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] --- | 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- -> HandlerT master IO ()-setCreds doRedirects creds = do+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+ auth <- authenticate creds+ case auth of+ Authenticated aid -> do+ setSession credsKey $ toPathPiece aid+ onLogin+ res <- selectRep $ do+ provideRepType typeHtml $+ fmap asHtml $ redirectUltDest $ loginDest y+ provideJsonMessage "Login Successful"+ sendResponse res++ UserError msg -> case authRoute y of Nothing -> do- sendResponseStatus unauthorized401 =<< (- selectRep $ do- provideRep $ authLayout $ toWidget [shamlet|<h1>Invalid login|]- provideJsonMessage "Invalid Login"- )- Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin- Just aid -> do- setSession credsKey $ toPathPiece aid- when doRedirects $ do- onLogin- res <- selectRep $ do- provideRepType typeHtml $ do- _ <- redirectUltDest $ loginDest y- return ()- provideJsonMessage "Login Successful"- sendResponse res+ 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 :: (YesodAuth site, ToJSON j)- => WidgetT site IO () -- ^ HTML- -> HandlerT site IO j -- ^ JSON- -> HandlerT site IO TypedContent+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- -> HandlerT master IO ()+-- @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 :: AuthHandler master TypedContent-getCheckR = lift $ do+getCheckR = do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status"@@ -331,12 +454,12 @@ <p>Not logged in. |] jsonCreds creds =- Object $ Map.fromList+ toJSON $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] -setUltDestReferer' :: AuthHandler master ()-setUltDestReferer' = lift $ do+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()+setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -344,14 +467,16 @@ getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master ()-getLogoutR = setUltDestReferer' >> redirectToPost LogoutR+getLogoutR = do+ tp <- getRouteToParent+ setUltDestReferer' >> redirectToPost (tp LogoutR) postLogoutR :: AuthHandler master ()-postLogoutR = lift $ clearCreds True+postLogoutR = clearCreds True -handlePluginR :: Text -> [Text] -> AuthHandler master ()+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do- master <- lift getYesod+ master <- getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) (authPlugins master) of@@ -362,67 +487,118 @@ -- 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 :: ( YesodAuth master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val- , b ~ YesodPersistBackend master+-- @since 1.1.0+maybeAuth :: ( YesodAuthPersist master+ , val ~ AuthEntity master , Key val ~ AuthId master- , PersistStore (b (HandlerT master IO)) , PersistEntity val- , YesodPersist master , Typeable val- ) => HandlerT master IO (Maybe (Entity val))-maybeAuth = runMaybeT $ do+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Maybe (Entity val))+maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair++-- | 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- MaybeT $ cachedAuth aid+ ae <- MaybeT $ cachedAuth aid+ return (aid, ae) -newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }- deriving Typeable --- | Constraint which states that the given site is an instance of @YesodAuth@--- and that its @AuthId@ 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 informatin on a given user.------ Since 1.2.0-type YesodAuthPersist master =- ( YesodAuth master- , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))- ~ PersistEntityBackend (AuthEntity master)- , Key (AuthEntity master) ~ AuthId master- , PersistStore (YesodPersistBackend master (HandlerT master IO))- , PersistEntity (AuthEntity master)- , YesodPersist master- , Typeable (AuthEntity master)- )+newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } --- | If the @AuthId@ for a given site is a persistent ID, this will give the--- value for that entity. E.g.:+-- | 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. ----- > type AuthId MySite = UserId--- > AuthEntity MySite ~ User+-- 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.2.0-type AuthEntity master = KeyEntity (AuthId master)+-- @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.+-- authenticated or responds with error 401 if this is an API client (expecting JSON). ----- Since 1.1.0-requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)-requireAuthId = maybeAuthId >>= maybe redirectLogin return+-- @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.+-- authenticated or responds with error 401 if this is an API client (expecting JSON). ----- Since 1.1.0-requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))-requireAuth = maybeAuth >>= maybe redirectLogin return+-- @since 1.1.0+requireAuth :: ( YesodAuthPersist master+ , val ~ AuthEntity master+ , Key val ~ AuthId master+ , PersistEntity val+ , Typeable val+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Entity val)+requireAuth = maybeAuth >>= maybe handleAuthLack return -redirectLogin :: Yesod master => HandlerT master IO 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"@@ -431,8 +607,11 @@ renderMessage = renderAuthMessage data AuthException = InvalidFacebookResponse- deriving (Show, Typeable)+ deriving Show instance Exception AuthException -instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where+instance YesodAuth master => YesodSubDispatch Auth master where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)++asHtml :: Html -> Html+asHtml = id
Yesod/Auth/BrowserId.hs view
@@ -1,25 +1,29 @@-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# 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 , 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 (when, unless)-import Text.Julius (julius, rawJS)+import Text.Julius (rawJS) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) import Data.ByteString (ByteString)@@ -28,9 +32,12 @@ pid :: Text pid = "browserid" -complete :: Route Auth-complete = PluginR pid []+forwardUrl :: AuthRoute+forwardUrl = PluginR pid [] +complete :: AuthRoute+complete = forwardUrl+ -- | A settings type for various configuration options relevant to BrowserID. -- -- See: <http://www.yesodweb.com/book/settings-types>@@ -64,20 +71,21 @@ , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do- master <- lift getYesod audience <- case bisAudience of Just a -> return a Nothing -> do r <- getUrlRender- return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR- memail <- lift $ checkAssertion audience assertion (authHttpManager master)+ tm <- getRouteToParent+ return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR+ manager <- authHttpManager+ memail <- checkAssertion audience assertion manager case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) "BrowserID login error."- Just email -> lift $ setCreds True Creds+ loginErrorMessage (tm LoginR) "BrowserID login error."+ Just email -> setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = []@@ -110,7 +118,7 @@ createOnClickOverride :: BrowserIdSettings -> (Route Auth -> Route master) -> Maybe (Route master)- -> WidgetT master IO Text+ -> WidgetFor master Text createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent@@ -159,5 +167,5 @@ -- name. createOnClick :: BrowserIdSettings -> (Route Auth -> Route master)- -> WidgetT master IO Text+ -> WidgetFor master Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing
Yesod/Auth/Dummy.hs view
@@ -1,30 +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 Text.Hamlet (hamlet)-import Yesod.Core+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 <- lift $ runInputPost $ ireq textField "ident"- lift $ 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,8 +1,91 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}+{-# 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@@ -14,6 +97,7 @@ , registerR , forgotPasswordR , setpassR+ , verifyR , isValidPass -- * Types , Email@@ -26,30 +110,36 @@ , loginLinkKey , setLoginLinkKey -- * Default handlers+ , defaultEmailLoginHandler , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler+ -- * Default helpers+ , defaultRegisterHelper ) where -import Network.Mail.Mime (randomString)-import Yesod.Auth-import System.Random-import Data.Digest.Pure.MD5-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Text (Text)-import Yesod.Core-import qualified Crypto.PasswordStore as PS+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 qualified Yesod.Auth.Message as Msg-import Control.Applicative ((<$>), (<*>))-import Yesod.Form-import Control.Monad (when)-import Data.Time (getCurrentTime, addUTCTime)-import Safe (readMay)+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"]@@ -57,9 +147,16 @@ forgotPasswordR = PluginR "email" ["forgot-password"] setpassR = PluginR "email" ["set-password"] -verify :: Text -> Text -> AuthRoute -- FIXME-verify eid verkey = PluginR "email" ["verify", eid, verkey]+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@@ -71,88 +168,153 @@ -- -- Note that any of these other identifiers must not be valid email addresses. ----- Since 1.2.0+-- @since 1.2.0 type Identifier = Text -- | Data stored in a database for each e-mail address. data EmailCreds site = EmailCreds- { emailCredsId :: AuthEmailId site+ { emailCredsId :: AuthEmailId site , emailCredsAuthId :: Maybe (AuthId site) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey- , emailCredsEmail :: Email+ , emailCredsEmail :: Email } -class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where+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 -> HandlerT site IO (AuthEmailId site)+ -- @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 -> HandlerT site IO ()+ -- @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 -> HandlerT site IO (Maybe VerKey)+ -- @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 -> HandlerT site IO ()+ -- @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. --- -- Since 1.1.0- verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))+ -- __/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 -> HandlerT site IO (Maybe SaltedPass)+ -- @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 -> HandlerT site IO ()+ -- @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 -> HandlerT site IO (Maybe (EmailCreds site))+ -- @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 -> HandlerT site IO (Maybe Email)+ -- @since 1.1.0+ getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email) -- | Generate a random alphanumeric string. --- -- Since 1.1.0- randomKey :: site -> IO Text- randomKey _ = do- stdgen <- newStdGen- return $ TS.pack $ fst $ randomString 10 stdgen+ -- @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+ -- @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 -> HandlerT site IO Bool+ -- @since 1.2.1+ needOldPassword :: AuthId site -> AuthHandler site Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey case mkey >>= readMay . TS.unpack of@@ -164,34 +326,59 @@ -- | Check that the given plain-text password meets minimum security standards. -- -- Default: password is at least three characters.- checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ())+ 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 -> HandlerT site IO Html- confirmationEmailSentResponse identifier = authLayout $ do- setTitleI Msg.ConfirmationEmailSentTitle- [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]+ -- @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+ -- @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.+ -- @since: 1.2.6 registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler @@ -201,7 +388,7 @@ -- -- Default: 'defaultForgotPasswordHandler'. --- -- Since: 1.2.6.+ -- @since: 1.2.6 forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler @@ -211,278 +398,552 @@ -- -- Default: 'defaultSetPasswordHandler'. --- -- Since: 1.2.6.+ -- @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 Html+ -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler -authEmail :: YesodAuthEmail m => AuthPlugin m+ -- | 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 $ \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-|]+ 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 >>= sendResponse+ 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 => HandlerT Auth (HandlerT master IO) Html+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+-- @since 1.2.6 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do- email <- newIdent- tp <- getRouteToParent- lift $ authLayout $ do+ (widget, enctype) <- generateFormPost registrationForm+ toParentRoute <- getRouteToParent+ authLayout $ do setTitleI Msg.RegisterLong [whamlet| <p>_{Msg.EnterEmail}- <form method="post" action="@{tp registerR}">+ <form method="post" action="@{toParentRoute registerR}" enctype=#{enctype}> <div id="registerForm">- <label for=#{email}>_{Msg.Email}:- <input ##{email} type="email" name="email" width="150" autofocus>+ ^{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", "")]+ } -registerHelper :: YesodAuthEmail master- => Bool -- ^ allow usernames?- -> Route Auth- -> HandlerT Auth (HandlerT master IO) Html-registerHelper allowUsername dest = do- y <- lift getYesod- midentifier <- lookupPostParam "email"- identifier <-- case midentifier of- Nothing -> loginErrorMessageI dest Msg.NoIdentifierProvided- Just x- | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->- return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'- | allowUsername -> return $ TS.strip x- | otherwise -> loginErrorMessageI dest Msg.InvalidEmailAddress+ (emailRes, emailView) <- mreq emailField emailSettings Nothing - mecreds <- lift $ getEmailCreds identifier- (lid, verKey, email) <-- case mecreds of- Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)- Just (EmailCreds lid _ _ Nothing email) -> do- key <- liftIO $ randomKey y- lift $ setVerifyKey lid key- return (lid, key, email)- Nothing- | allowUsername ->- loginErrorMessageI dest (Msg.IdentifierNotFound identifier)- | otherwise -> do- key <- liftIO $ randomKey y- lid <- lift $ addUnverified identifier key- return (lid, key, identifier)- render <- getUrlRender- let verUrl = render $ verify (toPathPiece lid) verKey- lift $ sendVerifyEmail email verKey verUrl- lift $ confirmationEmailSentResponse identifier+ let userRes = UserForm <$> emailRes+ let widget = do+ [whamlet|+ #{extra}+ ^{fvLabel emailView}+ ^{fvInput emailView}+ |] -postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html-postRegisterR = registerHelper False registerR+ return (userRes, widget) -getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+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+-- @since 1.2.6 defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do- tp <- getRouteToParent- email <- newIdent- lift $ authLayout $ do+ (widget, enctype) <- generateFormPost forgotPasswordForm+ toParent <- getRouteToParent+ authLayout $ do setTitleI Msg.PasswordResetTitle [whamlet| <p>_{Msg.PasswordResetPrompt}- <form method="post" action="@{tp forgotPasswordR}">- <div id="registerForm">- <label for=#{email}>_{Msg.ProvideIdentifier}- <input ##{email} type=text name="email" width="150" autofocus>- <button .btn>_{Msg.SendPasswordResetEmail}+ <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 -postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html-postForgotPasswordR = registerHelper True forgotPasswordR+ 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- -> HandlerT Auth (HandlerT site IO) Html-getVerifyR lid key = do- realKey <- lift $ getVerifyKey lid- memail <- lift $ getEmail lid+ -> 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 <- lift $ verifyAccount lid+ muid <- verifyAccount lid case muid of- Nothing -> return ()+ Nothing -> invalidKey mr Just uid -> do- lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?- lift $ setMessageI Msg.AddressVerified- lift $ setLoginLinkKey uid- redirect setpassR- _ -> return ()- lift $ authLayout $ do- setTitleI Msg.InvalidKey+ 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>_{Msg.InvalidKey}+<p>_{msgIk} |] -postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()++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- (identifier, pass) <- lift $ runInputPost $ (,)+ result <- runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password"- mecreds <- lift $ getEmailCreds identifier- maid <-- case ( mecreds >>= emailCredsAuthId- , emailCredsEmail <$> mecreds- , emailCredsStatus <$> mecreds- ) of- (Just aid, Just email, Just True) -> do- mrealpass <- lift $ getPassword aid- case mrealpass of- Nothing -> return Nothing- Just realpass -> return $- if isValidPass pass realpass- then Just email- else Nothing- _ -> return Nothing- let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier- case maid of- Just email ->- lift $ setCreds True $ Creds- (if isEmail then "email" else "username")- email- [("verifiedEmail", email)]- Nothing -> do- loginErrorMessageI LoginR $- if isEmail- then Msg.InvalidEmailPass- else Msg.InvalidUsernamePass -getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+ 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 <- lift maybeAuthId+ maid <- maybeAuthId case maid of- Just _ -> return () Nothing -> loginErrorMessageI LoginR Msg.BadSetPass- needOld <- maybe (return True) (lift . needOldPassword) maid- setPasswordHandler needOld+ Just aid -> do+ needOld <- needOldPassword aid+ setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. ----- Since: 1.2.6-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master Html+-- @since 1.2.6+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do- tp <- getRouteToParent- pass0 <- newIdent- pass1 <- newIdent- pass2 <- newIdent- lift $ authLayout $ do- setTitleI Msg.SetPassTitle- [whamlet|-$newline never-<h3>_{Msg.SetPass}-<form method="post" action="@{tp setpassR}">- <table>- $if needOld- <tr>- <th>- <label for=#{pass0}>Current Password- <td>- <input ##{pass0} type="password" name="current" autofocus>- <tr>- <th>- <label for=#{pass1}>_{Msg.NewPass}- <td>- <input ##{pass1} type="password" name="new" :not needOld:autofocus>- <tr>- <th>- <label for=#{pass2}>_{Msg.ConfirmPass}- <td>- <input ##{pass2} type="password" name="confirm">- <tr>- <td colspan="2">- <input type="submit" value=_{Msg.SetPassTitle}>-|]+ 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 -postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()-postPasswordR = do- maid <- lift maybeAuthId- aid <- case maid of- Nothing -> loginErrorMessageI LoginR Msg.BadSetPass- Just aid -> return aid+ 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}>+ |] - tm <- getRouteToParent+ 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", "")]+ } - needOld <- lift $ needOldPassword aid- when needOld $ do- current <- lift $ runInputPost $ ireq textField "current"- mrealpass <- lift $ getPassword aid- case mrealpass of- Nothing ->- lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"- Just realpass- | isValidPass current realpass -> return ()- | otherwise ->- lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"+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)) - (new, confirm) <- lift $ runInputPost $ (,)- <$> ireq textField "new"- <*> ireq textField "confirm"- when (new /= confirm) $- loginErrorMessageI setpassR Msg.PassMismatch+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" - isSecure <- lift $ checkPasswordSecurity aid new- case isSecure of- Left e -> lift $ loginErrorMessage (tm setpassR) e- Right () -> return ()+ 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 - salted <- liftIO $ saltPass new- lift $ do- y <- getYesod- setPassword aid salted- setMessageI Msg.PassUpdated- deleteSession loginLinkKey- redirect $ afterPasswordRoute y+ mr <- getMessageRender+ selectRep $ do+ provideRep $ do+ route <- afterPasswordRouteHandler+ fmap asHtml $ redirect route+ provideJsonMessage (mr msgOk) saltLength :: Int saltLength = 5@@ -490,11 +951,12 @@ -- | Salt a password with a randomly generated salt. saltPass :: Text -> IO Text saltPass = fmap (decodeUtf8With lenientDecode)- . flip PS.makePassword 14+ . flip PS.makePassword 16 . encodeUtf8 saltPass' :: String -> String -> String-saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)+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@@ -515,14 +977,23 @@ -- | Session variable set when user logged in via a login link. See -- 'needOldPassword'. ----- Since 1.2.1+-- @since 1.2.1 loginLinkKey :: Text loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK" -- | Set 'loginLinkKey' to the current time. ----- Since 1.2.1-setLoginLinkKey :: (YesodAuthEmail site, MonadHandler m, HandlerSite m ~ site) => AuthId site -> m ()+-- @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,87 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}--- | 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.Core-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|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]- dispatch "GET" ["forward"] = do- render <- getUrlRender- let complete' = render complete- master <- lift 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- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))- 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 master => [(Text, Text)] -> AuthHandler master ()-completeHelper gets' = do- master <- lift getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- tm <- getRouteToParent- either (onFailure tm) (onSuccess tm) eres- where- onFailure tm err = do- lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)- onSuccess tm 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) -> lift $ setCreds True $ Creds pid email []- (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"- (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"
+ 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,278 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# 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------ /WARNING/: This module was /not/ designed with security in mind, and is not--- suitable for production sites. In the near future, it will likely be either--- deprecated or rewritten to have a more secure implementation. For more--- information, see: <https://github.com/yesodweb/yesod/issues/668>.------ 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.Form-import Yesod.Auth-import Yesod.Core-import Text.Hamlet (hamlet)--import Control.Applicative ((<$>), (<*>))-import Control.Monad (replicateM,liftM)-import Data.Typeable--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- , b ~ YesodPersistBackend yesod- , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT yesod IO))- , PersistEntity user- , HashDBUser user- ) => - Unique user -- ^ User unique identifier- -> Text -- ^ Password in plaint-text- -> HandlerT yesod IO 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- , b ~ YesodPersistBackend y- , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT y IO))- )- => (Text -> Maybe (Unique user))- -> HandlerT Auth (HandlerT y IO) ()-postLoginR uniq = do- (mu,mp) <- lift $ runInputPost $ (,)- <$> iopt textField "username"- <*> iopt textField "password"-- isValid <- lift $ fromMaybe (return False) - (validateUser <$> (uniq =<< mu) <*> mp)- if isValid - then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) "Invalid username/password"----- | 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- , Key user ~ AuthId master- , b ~ YesodPersistBackend master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT master IO))- )- => (AuthRoute -> Route master) -- ^ your site's Auth Route- -> (Text -> Maybe (Unique user)) -- ^ gets user ID- -> Creds master -- ^ the creds argument- -> HandlerT master IO (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 -> loginErrorMessage (authR LoginR) "User not found"---- | 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- , b ~ YesodPersistBackend m- , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT m IO)))- => (Text -> Maybe (Unique user)) -> AuthPlugin m-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- deriving Typeable-|]--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@@ -13,11 +14,16 @@ , japaneseMessage , finnishMessage , chineseMessage+ , croatianMessage , spanishMessage , czechMessage+ , russianMessage+ , dutchMessage+ , danishMessage+ , koreanMessage+ , romanianMessage ) where -import Data.Monoid (mappend) import Data.Text (Text) data AuthMessage =@@ -26,6 +32,7 @@ | LoginGoogle | LoginYahoo | Email+ | UserName | IdentifierNotFound Text | Password | Register@@ -34,6 +41,8 @@ | ConfirmationEmailSentTitle | ConfirmationEmailSent Text | AddressVerified+ | EmailVerifiedChangePass+ | EmailVerified | InvalidKeyTitle | InvalidKey | InvalidEmailPass@@ -57,7 +66,13 @@ | 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@@ -65,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"@@ -89,11 +106,11 @@ 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"@@ -104,6 +121,9 @@ 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"@@ -111,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ê."@@ -121,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"@@ -147,6 +171,9 @@ 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"@@ -154,7 +181,9 @@ 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."@@ -164,6 +193,8 @@ 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"@@ -178,18 +209,21 @@ spanishMessage LoginViaEmail = "Entrar mediante una cuenta de correo" spanishMessage InvalidLogin = "Login inválido" spanishMessage NowLoggedIn = "Usted ha ingresado al sitio"-spanishMessage LoginTitle = "Login"+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 = "Contraseña actualizada"+spanishMessage PasswordResetTitle = "Actualización de contraseña" spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"-spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"+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"@@ -197,7 +231,9 @@ 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."@@ -207,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"@@ -234,23 +272,30 @@ 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"@@ -259,24 +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 Email-Adresse oder kein Nutzername angegeben"-germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter" germanMessage PasswordResetTitle = "Passwort zurücksetzen"-germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"-germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"-germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."+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"--- TODO-germanMessage i@(IdentifierNotFound _) = englishMessage i+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é"@@ -284,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é"@@ -294,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"@@ -305,21 +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 NoIdentifierProvided = "No email/username provided"-frenchMessage InvalidEmailAddress = "Invalid email address provided"-frenchMessage PasswordResetTitle = "Password Reset"-frenchMessage ProvideIdentifier = "Email or Username"-frenchMessage SendPasswordResetEmail = "Send password reset email"-frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."-frenchMessage InvalidUsernamePass = "Invalid username/password combination"--- TODO-frenchMessage i@(IdentifierNotFound _) = englishMessage i+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"@@ -327,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."@@ -337,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"@@ -363,6 +420,9 @@ 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識別子がありません"@@ -370,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 = "メールアドレスを入力してください。確認メールが送られます"@@ -380,6 +442,8 @@ email `mappend` " に送信しました" japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerified = "アドレスは認証されました" japaneseMessage InvalidKeyTitle = "認証キーが無効です" japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです" japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"@@ -397,15 +461,18 @@ japaneseMessage LoginTitle = "ログイン" japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください" japaneseMessage PleaseProvidePassword = "パスワードを入力してください"-japaneseMessage NoIdentifierProvided = "No email/username provided"-japaneseMessage InvalidEmailAddress = "Invalid email address provided"-japaneseMessage PasswordResetTitle = "Password Reset"-japaneseMessage ProvideIdentifier = "Email or Username"-japaneseMessage SendPasswordResetEmail = "Send password reset email"-japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."-japaneseMessage InvalidUsernamePass = "Invalid username/password combination"+japaneseMessage NoIdentifierProvided = "メールアドレス/ユーザ名が入力されていません"+japaneseMessage InvalidEmailAddress = "メールアドレスが無効です"+japaneseMessage PasswordResetTitle = "パスワードの再設定"+japaneseMessage ProvideIdentifier = "メールアドレスまたはユーザ名"+japaneseMessage SendPasswordResetEmail = "パスワード再設定用メールの送信"+japaneseMessage PasswordResetPrompt = "以下にメールアドレスまたはユーザ名を入力してください。パスワードを再設定するためのメールが送信されます。"+japaneseMessage InvalidUsernamePass = "ユーザ名とパスワードの組み合わせが間違っています" japaneseMessage (IdentifierNotFound ident) =- "「" `mappend` ident `mappend` "」は正しくないログインので、または未入力の項目があります。"+ 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"@@ -413,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."@@ -424,6 +493,8 @@ "." 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."@@ -450,6 +521,9 @@ 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"@@ -457,7 +531,9 @@ chineseMessage LoginGoogle = "用Google帐户登录" chineseMessage LoginYahoo = "用Yahoo帐户登录" chineseMessage Email = "邮箱"+chineseMessage UserName = "用户名" chineseMessage Password = "密码"+chineseMessage CurrentPassword = "当前密码" chineseMessage Register = "注册" chineseMessage RegisterLong = "注册新帐户" chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"@@ -467,6 +543,8 @@ email `mappend` "." chineseMessage AddressVerified = "地址验证成功，请设置新密码"+chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"+chineseMessage EmailVerified = "地址验证成功" chineseMessage InvalidKeyTitle = "无效的验证码" chineseMessage InvalidKey = "对不起，验证码无效。" chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"@@ -491,8 +569,10 @@ chineseMessage SendPasswordResetEmail = "发送密码重置邮件" chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。" chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"--- TODO-chineseMessage i@(IdentifierNotFound _) = englishMessage i+chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident+chineseMessage Logout = "注销"+chineseMessage LogoutTitle = "注销"+chineseMessage AuthError = "验证错误" czechMessage :: AuthMessage -> Text czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"@@ -500,7 +580,9 @@ 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."@@ -508,6 +590,8 @@ 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"@@ -534,3 +618,301 @@ 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,7 +1,9 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}+ module Yesod.Auth.OpenId ( authOpenId , forwardUrl@@ -16,10 +18,9 @@ import Yesod.Form import Yesod.Core-import Text.Cassius (cassius) 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 @@ -36,7 +37,10 @@ AuthPlugin "openid" dispatch login where complete = PluginR "openid" ["complete"]++ name :: Text name = "openid_identifier"+ login tm = do ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the@@ -50,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}">@@ -60,19 +61,19 @@ <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 <- lift $ runInputGet $ iopt textField name+ roid <- runInputGet $ iopt textField name case roid of Just oid -> do+ tm <- getRouteToParent render <- getUrlRender- let complete' = render complete- master <- lift 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- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $- show (err :: SomeException)+ Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues@@ -85,16 +86,15 @@ completeHelper idType posts dispatch _ _ = notFound -completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do- master <- lift getYesod- eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)+ manager <- authHttpManager+ eres <- tryAny $ OpenId.authenticateClaimed gets' manager either onFailure onSuccess eres where- onFailure err = do + onFailure err = do tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $- show (err :: SomeException)+ loginErrorMessage (tm LoginR) $ T.pack $ show err onSuccess oir = do let claimed = case OpenId.oirClaimed oir of@@ -108,7 +108,7 @@ case idType of OPLocal -> OpenId.oirOpLocal oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- lift $ setCreds True $ Creds "openid" i gets''+ 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
@@ -1,10 +1,13 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module Yesod.Auth.Routes where import Yesod.Core
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@@ -11,17 +13,16 @@ import Control.Monad (mplus) import Yesod.Core-import Text.Hamlet (hamlet) 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@@ -33,14 +34,16 @@ $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 <- lift 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))@@ -48,7 +51,7 @@ $ maybe id (\x -> (:) ("displayName", x)) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) []- lift $ 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.2.7.1+version: 1.6.12.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -7,61 +8,72 @@ synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable-cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/-description: 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.- .- * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin 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- , bytestring >= 0.9.1.4- , yesod-core >= 1.2 && < 1.3- , wai >= 1.4- , template-haskell- , pureMD5 >= 2.0- , random >= 1.0.0.2- , text >= 0.7- , mime-mail >= 0.3- , yesod-persistent >= 1.2- , hamlet >= 1.1- , shakespeare- , shakespeare-css >= 1.0- , shakespeare-js >= 1.0.2- , containers- , unordered-containers- , yesod-form >= 1.3 && < 1.4- , transformers >= 0.2.2- , persistent >= 1.2 && < 1.4- , persistent-template >= 1.2 && < 1.4- , SHA >= 1.4.1.3- , http-conduit >= 1.5- , aeson >= 0.5- , pwstore-fast >= 2.2- , lifted-base >= 0.1+ 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- , network- , http-types- , file-embed- , email-validate >= 1.0+ , bytestring >= 0.9.1.4+ , conduit >= 1.3+ , conduit-extra+ , containers+ , crypton , data-default- , resourcet+ , 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 , time+ , transformers >= 0.2.2+ , 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