yesod-auth-1.4.13.5/0000755000000000000000000000000012762244274012225 5ustar0000000000000000yesod-auth-1.4.13.5/ChangeLog.md0000644000000000000000000000271012762244274014376 0ustar0000000000000000## 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. yesod-auth-1.4.13.5/LICENSE0000644000000000000000000000207512762244274013236 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-auth-1.4.13.5/persona_sign_in_blue.png0000644000000000000000000000714412762244274017125 0ustar0000000000000000PNG  IHDRm+IDATxYWTy+yƈ=iRJ`XMҥ 1"z5T1 κL ̬^[g)$;+a2&{C#0)FtU?cFa(Gtlx뾼oDQי^ƇyCFa(FCW8qg=u_X{F ݷt ϟ Г:fɽ;r`uM<+|{L?I{cEZVnK5HrUʹMzC@^H)-TaT7 /?'G;Ch"XZZʊf.+һbw&n+FzX¤ߚӁ i3iX!^¶ /H8@z`uV/LtcU7Ve$;DW߃l`¸U=lg|~6Q,/1>ѷ^}0w\Z֤}]XOr܂ L7iH¹`>+ziU?={[R3Z$P= Wd#0c=!&ۿ"&+0LMM-> Zu{J;c[cA20"X; H:{EP+"fxp,Ac7`yBܓiNubyb3ɗdCOA.Ae~An~a} OCGen5jt8^>.Ug|o9?壘8箴rH.]똒^38ʞ(=i3)xR~KiOGs#šdGqhM3!rdCs=)ڲ>&… aaa Ӿ^X.$x\w y ]FvUBRYߎrD 7E$\$9ͻ_fKV>k/ÉJtFA^I5O.F$\)4}>u8]D}x5 Rz\&4wߔLqfEL.\CeYFIrtk%hqM ^%quZVkߌפ~MT1=M}`iAi +qY1cݹX)s;h I~źKe8]34Xzō\&$"cYrޖ,ޙT$;0m$zfy\ZdIfyؖVHZ/6_c] ]X=Qu~fzb(,;Q5`z|:8krM \Sl=7.ށ.;М7o=iM הn A%{r`Kj1"]C_x>I*:YT[+R$o$؅WHۭ'rK*+ͱdeQj ,=zE/:䗩AzN#nu;ӫ"q?xX!הq5%X{[֩!qω[w@oKR'q 1O/GL$0jVgX\8вQ5Yn/:l˨Gz=)ğ c3g&=퓝pg$vB"C4.&Zi/$NՎ 7"x MB%ACN 曘:u*ٳ5i^gG1;FdS[QzlB* pv*Ȇ"I2g+xX#B~o`9hr\Cl3v5<))>\g yݏ Ƀա""ԩ 6 {T<P&RYMN,eY1mVl,f[1oS$hGrԯzvb@?#v .W女Xפ]3?9WՒ3ա|G+SVXx>[xw1sL̚5-Ak>ّ=Mj 6E7?$OVo[|1"rK%%E C~ŰnPmªLX,ß!zkG%ZEY4$?v /p鏢+j~Nzq^KĶܚ:e̊g?"@_Ir94Ϡ{]C\EEyn?Njפ]{'OҶ!gXWAu[O N铄nl"x}#{;lo0Ŵ fx\,X(wU: ƘRR7p g?Ł~"~ \N WCUT{3agpbsh~yA/> e/wiu O~Hn{åj:u6i՞3^.y#R |xGo֗tNn;әK.I>\ ٘%ӮINsoDփgp9RT.,})" > 5 #7 ufZ¾0?XwW4y8m T7m}x$AdK ?/HXm#0gc$-?uz3F"&kqL $?A~#HȤ&\l(N#^VK1(͙-@̩eO(2)¯qu4ѽ// DQ~cB# .#caڴiD^]Ų&B& f~k];O^⑜FM0'Z|z`HXXzaRa"P\(QO|l| p 7l1 CH%A&6>Z P 7 % [F #$ӝl, *gXh0`~b篂SF`"Xmɺຈ|N{aƺFaHEDiIENDB`yesod-auth-1.4.13.5/README.md0000644000000000000000000000137412762244274013511 0ustar0000000000000000## 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-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://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module. yesod-auth-1.4.13.5/Setup.lhs0000644000000000000000000000021712762244274014035 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain yesod-auth-1.4.13.5/yesod-auth.cabal0000644000000000000000000000621012762244274015272 0ustar0000000000000000name: yesod-auth version: 1.4.13.5 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin maintainer: Michael Snoyman synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/ description: API docs and the README are available at 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.4.20 && < 1.5 , wai >= 1.4 , template-haskell , base16-bytestring , cryptohash , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3 , yesod-persistent >= 1.4 , shakespeare , containers , unordered-containers , yesod-form >= 1.4 && < 1.5 , transformers >= 0.2.2 , persistent >= 2.1 && < 2.7 , persistent-template >= 2.1 && < 2.7 , http-client , http-conduit >= 2.1 , aeson >= 0.7 , lifted-base >= 0.1 , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , http-types , file-embed , email-validate >= 1.0 , data-default , resourcet , safe , time , base64-bytestring , byteable , binary , http-client , blaze-builder , conduit , conduit-extra , nonce >= 1.0.2 && < 1.1 if flag(network-uri) build-depends: network-uri >= 2.6 else build-depends: network < 2.6 exposed-modules: Yesod.Auth Yesod.Auth.BrowserId Yesod.Auth.Dummy Yesod.Auth.Email Yesod.Auth.OpenId Yesod.Auth.Rpxnow Yesod.Auth.Message Yesod.Auth.GoogleEmail Yesod.Auth.GoogleEmail2 Yesod.Auth.Hardcoded other-modules: Yesod.Auth.Routes Yesod.PasswordStore ghc-options: -Wall source-repository head type: git location: https://github.com/yesodweb/yesod yesod-auth-1.4.13.5/Yesod/0000755000000000000000000000000012762244274013310 5ustar0000000000000000yesod-auth-1.4.13.5/Yesod/Auth.hs0000644000000000000000000004746112762244274014561 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite Auth , AuthRoute , Route (..) , AuthPlugin (..) , getAuth , YesodAuth (..) , YesodAuthPersist (..) -- * Plugin interface , Creds (..) , setCreds , setCredsRedirect , clearCreds , loginErrorMessage , loginErrorMessageI -- * User functions , AuthenticationResult (..) , defaultMaybeAuthId , defaultLoginHandler , maybeAuthPair , maybeAuth , requireAuthId , requireAuthPair , requireAuth -- * Exception , AuthException (..) -- * Helper , AuthHandler -- * Internal , credsKey , provideJsonMessage , messageJson401 , asHtml ) where import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe import Yesod.Auth.Routes import Data.Aeson hiding (json) 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.Client (Manager, Request, withResponse, Response, BodyReader) import qualified Network.Wai as W import Yesod.Core import Yesod.Core.Types (HandlerT(..), unHandlerT) import Yesod.Persist import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception) import Network.HTTP.Types (Status, internalServerError500, unauthorized401) import Control.Monad.Trans.Resource (MonadResourceBase) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad (void) type AuthRoute = Route Auth type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) 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 TypedContent , apLogin :: (Route Auth -> Route master) -> WidgetT master IO () } getAuth :: a -> Auth getAuth = const Auth -- | User credentials data Creds master = Creds { credsPlugin :: Text -- ^ How the user was authenticated , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. , credsExtra :: [(Text, Text)] } 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 -- | Default destination on successful login, if no other -- destination exists. loginDest :: master -> Route master -- | Default destination on successful logout, if no other -- 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 :: Creds master -> HandlerT master IO (AuthenticationResult master) authenticate creds = do muid <- getAuthId creds return $ maybe (UserError Msg.InvalidLogin) Authenticated muid -- | Determine the ID associated with the set of credentials. -- -- Default implementation is in terms of @'authenticate'@ -- getAuthId :: Creds master -> HandlerT master IO (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 = defaultLoginHandler -- | Used for i18n of messages provided by this package. renderAuthMessage :: master -> [Text] -- ^ languages -> AuthMessage -> Text renderAuthMessage _ _ = defaultMessage -- | After login and logout, redirect to the referring page, instead of -- 'loginDest' and 'logoutDest'. Default is 'False'. redirectToReferer :: master -> Bool redirectToReferer _ = False -- | 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 -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. onLogin :: HandlerT master IO () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing onLogout :: HandlerT master IO () onLogout = return () -- | Retrieves user credentials, if user is authenticated. -- -- By default, this calls 'defaultMaybeAuthId' to get the user ID from the -- session. This can be overridden to allow authentication via other means, -- such as checking for a special token in a request header. This is -- 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)) default maybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) => HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls -- @addMessage@ with "error" as status and redirects to @dest@. onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest -- | runHttpRequest gives you a chance to handle an HttpException and retry -- The default behavior is to simply execute the request which will throw an exception on failure -- -- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request. -- This is an experimental API that is not broadly used throughout the yesod-auth code base runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a runHttpRequest req inner = do man <- authHttpManager <$> getYesod HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-} {-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-} -- | Internal session key used to hold the authentication information. -- -- Since 1.2.3 credsKey :: Text credsKey = "_ID" -- | Retrieves user credentials from the session, if user is authenticated. -- -- This function does /not/ confirm that the credentials are valid, see -- 'maybeAuthIdRaw' for more information. -- -- Since 1.1.2 defaultMaybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) => HandlerT master IO (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s _ <- MaybeT $ cachedAuth aid return aid cachedAuth :: (YesodAuthPersist master, Typeable (AuthEntity master)) => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached . fmap CachedMaybeAuth . getAuthEntity -- | 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 lift $ authLayout $ do setTitleI Msg.LoginTitle master <- getYesod mapM_ (flip apLogin tp) (authPlugins master) loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) => Route child -> AuthMessage -> HandlerT child (HandlerT master m) TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent lift $ loginErrorMessageMasterI (toParent dest) msg loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) => Route master -> AuthMessage -> HandlerT master 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 -> Text -> HandlerT master m TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent messageJson401 = messageJsonStatus unauthorized401 messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent messageJson500 = messageJsonStatus internalServerError500 messageJsonStatus :: MonadResourceBase m => Status -> Text -> HandlerT master m Html -> HandlerT master m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do let obj = object ["message" .= msg] void $ sendResponseStatus status obj return obj provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] setCredsRedirect :: YesodAuth master => Creds master -- ^ new credentials -> HandlerT master IO TypedContent setCredsRedirect creds = do y <- getYesod 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 msg' <- renderMessage' msg messageJson401 msg' $ authLayout $ -- TODO toWidget [whamlet|

_{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|

_{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 :: YesodAuth master => Bool -- ^ if HTTP redirects should be done -> Creds master -- ^ new credentials -> HandlerT master IO () 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 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 () clearCreds doRedirects = do y <- getYesod onLogout deleteSession credsKey when doRedirects $ do redirectUltDest $ logoutDest y getCheckR :: AuthHandler master TypedContent getCheckR = lift $ do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status" toWidget $ html' creds) (return $ jsonCreds creds) where html' creds = [shamlet| $newline never

Authentication Status $maybe _ <- creds

Logged in. $nothing

Not logged in. |] jsonCreds creds = Object $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] setUltDestReferer' :: AuthHandler master () setUltDestReferer' = lift $ do master <- getYesod when (redirectToReferer master) setUltDestReferer getLoginR :: AuthHandler master Html getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master () getLogoutR = setUltDestReferer' >> redirectToPost LogoutR postLogoutR :: AuthHandler master () postLogoutR = lift $ clearCreds True handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do master <- lift getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) (authPlugins master) of [] -> notFound ap:_ -> apDispatch ap method pieces -- | Similar to 'maybeAuthId', but additionally look up the value associated -- with the user\'s database identifier to get the value in the database. This -- assumes that you are using a Persistent database. -- -- Since 1.1.0 maybeAuth :: ( YesodAuthPersist master , val ~ AuthEntity master , Key val ~ AuthId master , PersistEntity val , Typeable val ) => HandlerT master IO (Maybe (Entity val)) maybeAuth = runMaybeT $ do (aid, ae) <- MaybeT maybeAuthPair return $ Entity aid ae -- | Similar to 'maybeAuth', but doesn’t assume that you are using a -- Persistent database. -- -- Since 1.4.0 maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master)) => HandlerT master IO (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid return (aid, ae) newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } deriving Typeable -- | Class which states that the given site is an instance of @YesodAuth@ -- and that its @AuthId@ is a lookup key for the full user information in -- a @YesodPersist@ database. -- -- The default implementation of @getAuthEntity@ assumes that the @AuthId@ -- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the -- given value. This is the common case in Yesod, and means that you can -- easily look up the full information on a given user. -- -- Since 1.4.0 class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- | If the @AuthId@ for a given site is a persistent ID, this will give the -- value for that entity. E.g.: -- -- > type AuthId MySite = UserId -- > AuthEntity MySite ~ User -- -- Since 1.2.0 type AuthEntity master :: * type AuthEntity master = KeyEntity (AuthId master) getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) #if MIN_VERSION_persistent(2,5,0) default getAuthEntity :: ( YesodPersistBackend master ~ backend , PersistRecordBackend (AuthEntity master) backend , Key (AuthEntity master) ~ AuthId master , PersistStore backend ) => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) #else default getAuthEntity :: ( YesodPersistBackend master ~ PersistEntityBackend (AuthEntity master) , Key (AuthEntity master) ~ AuthId master , PersistStore (YesodPersistBackend master) , PersistEntity (AuthEntity master) ) => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) #endif getAuthEntity = runDB . get type family KeyEntity key type instance KeyEntity (Key x) = x -- | Similar to 'maybeAuthId', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- Since 1.1.0 requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- Since 1.1.0 requireAuth :: ( YesodAuthPersist master , val ~ AuthEntity master , Key val ~ AuthId master , PersistEntity val , Typeable val ) => HandlerT master IO (Entity val) requireAuth = maybeAuth >>= maybe handleAuthLack return -- | 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)) => HandlerT master IO (AuthId master, AuthEntity master) requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return handleAuthLack :: Yesod master => HandlerT master IO a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin redirectLogin :: Yesod master => HandlerT master IO a redirectLogin = do y <- getYesod setUltDestCurrent case authRoute y of Just z -> redirect z Nothing -> permissionDenied "Please configure authRoute" instance YesodAuth master => RenderMessage master AuthMessage where renderMessage = renderAuthMessage data AuthException = InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html asHtml = id yesod-auth-1.4.13.5/Yesod/PasswordStore.hs0000644000000000000000000004452112762244274016471 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, BangPatterns #-} {-# LANGUAGE CPP #-} -- | -- Module : Crypto.PasswordStore -- Copyright : (c) Peter Scott, 2011 -- License : BSD-style -- -- Maintainer : pjscott@iastate.edu -- Stability : experimental -- Portability : portable -- -- 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. module Yesod.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.Hash as CH import qualified Crypto.Hash.SHA256 as H 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.Byteable (toBytes) 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 --------------------- -- 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. pbkdf1 :: ByteString -> Salt -> Int -> ByteString pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1) where first_hash = H.finalize $ H.init `H.update` password `H.update` salt -- | 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 (H.hash bs) (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 = toBytes (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. 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 - 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'. 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 | length broken /= 4 || algorithm /= "sha256" || B.length hash /= 44 = Nothing | otherwise = case B.readInt strBS of Just (strength, _) -> Just (strength, SaltBS salt, hash) Nothing -> Nothing where broken = B.split '|' pw [algorithm, strBS, salt, hash] = broken -- | 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. 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 -- 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@. 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=" 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 -- 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. 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. 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. 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'. 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. 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. 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. 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. 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. 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) #if !MIN_VERSION_base(4, 6, 0) -- | Strict version of 'modifySTRef' modifySTRef' :: STRef s a -> (a -> a) -> ST s () modifySTRef' ref f = do x <- readSTRef ref let x' = f x x' `seq` writeSTRef ref x' #endif #if MIN_VERSION_bytestring(0, 10, 0) toStrict :: BL.ByteString -> BS.ByteString toStrict = BL.toStrict fromStrict :: BS.ByteString -> BL.ByteString fromStrict = BL.fromStrict #else toStrict :: BL.ByteString -> BS.ByteString toStrict = BS.concat . BL.toChunks fromStrict :: BS.ByteString -> BL.ByteString fromStrict = BL.fromChunks . return #endif yesod-auth-1.4.13.5/Yesod/Auth/0000755000000000000000000000000012762244274014211 5ustar0000000000000000yesod-auth-1.4.13.5/Yesod/Auth/BrowserId.hs0000644000000000000000000001305212762244274016446 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} -- | 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 qualified Data.Text as T import Data.Maybe (fromMaybe) import Control.Monad (when, unless) import Text.Julius (rawJS) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) import Data.ByteString (ByteString) import Data.Default pid :: Text pid = "browserid" forwardUrl :: AuthRoute forwardUrl = PluginR pid [] complete :: AuthRoute complete = forwardUrl -- | A settings type for various configuration options relevant to BrowserID. -- -- See: -- -- Since 1.2.0 data BrowserIdSettings = BrowserIdSettings { bisAudience :: Maybe Text -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the -- approot. -- -- Default: @Nothing@ -- -- Since 1.2.0 , bisLazyLoad :: Bool -- ^ Use asynchronous Javascript loading for the BrowserID JS file. -- -- Default: @True@. -- -- Since 1.2.0 } instance Default BrowserIdSettings where def = BrowserIdSettings { bisAudience = Nothing , bisLazyLoad = True } authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m authBrowserId bis@BrowserIdSettings {..} = AuthPlugin { apName = pid , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do master <- 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) case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent lift $ loginErrorMessage (tm LoginR) "BrowserID login error." Just email -> lift $ setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = [] } ("GET", ["static", "sign-in.png"]) -> sendResponse ( "image/png" :: ByteString , toContent $(embedFile "persona_sign_in_blue.png") ) (_, []) -> badMethod _ -> notFound , apLogin = \toMaster -> do onclick <- createOnClick bis toMaster autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius|#{rawJS onclick}();|] toWidget [hamlet| $newline never

|] } where loginIcon = PluginR pid ["static", "sign-in.png"] stripScheme t = fromMaybe t $ T.stripPrefix "//" $ snd $ T.breakOn "//" t -- | Generates a function to handle on-click events, and returns that function -- name. createOnClickOverride :: BrowserIdSettings -> (Route Auth -> Route master) -> Maybe (Route master) -> WidgetT master IO Text createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent render <- getUrlRender let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR) loginRoute = maybe (toMaster LoginR) id mOnRegistration toWidget [julius| function #{rawJS onclick}() { if (navigator.id) { navigator.id.watch({ onlogin: function (assertion) { if (assertion) { document.location = "@{toMaster complete}/" + assertion; } }, onlogout: function () {} }); navigator.id.request({ returnTo: #{login} + "?autologin=true" }); } else { alert("Loading, please try again"); } } |] when bisLazyLoad $ toWidget [julius| (function(){ var bid = document.createElement("script"); bid.async = true; bid.src = #{toJSON browserIdJs}; var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(bid, s); })(); |] autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius|#{rawJS onclick}();|] return onclick where getPath t = fromMaybe t $ do uri <- parseURI $ T.unpack t return $ T.pack $ uriPath uri -- | Generates a function to handle on-click events, and returns that function -- name. createOnClick :: BrowserIdSettings -> (Route Auth -> Route master) -> WidgetT master IO Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing yesod-auth-1.4.13.5/Yesod/Auth/Dummy.hs0000644000000000000000000000201212762244274015633 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -- | 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. module Yesod.Auth.Dummy ( authDummy ) where import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) import Yesod.Core authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where dispatch "POST" [] = do ident <- lift $ runInputPost $ ireq textField "ident" lift $ setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = do request <- getRequest toWidget [hamlet| $newline never

$maybe t <- reqToken request Your new identifier is: # |] yesod-auth-1.4.13.5/Yesod/Auth/Email.hs0000644000000000000000000006350212762244274015602 0ustar0000000000000000{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# 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 interoprate 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 module Yesod.Auth.Email ( -- * Plugin authEmail , YesodAuthEmail (..) , EmailCreds (..) , saltPass -- * Routes , loginR , registerR , forgotPasswordR , setpassR , verifyR , isValidPass -- * Types , Email , VerKey , VerUrl , SaltedPass , VerStatus , Identifier -- * Misc , loginLinkKey , setLoginLinkKey -- * Default handlers , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler ) where import Yesod.Auth import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form import qualified Yesod.PasswordStore as PS import Control.Applicative ((<$>), (<*>)) import qualified Crypto.Hash.MD5 as H import qualified Crypto.Nonce as Nonce import Data.ByteString.Base16 as B16 import Data.Text (Text) import qualified Data.Text as TS import qualified Data.Text as T 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 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] registerR = PluginR "email" ["register"] forgotPasswordR = PluginR "email" ["forgot-password"] setpassR = PluginR "email" ["set-password"] -- | -- -- Since 1.4.5 verifyR :: Text -> Text -> AuthRoute -- FIXME verifyR eid verkey = PluginR "email" ["verify", eid, verkey] type Email = Text type VerKey = Text type VerUrl = Text type SaltedPass = Text type VerStatus = Bool -- | An Identifier generalizes an email address to allow users to log in with -- some other form of credentials (e.g., username). -- -- Note that any of these other identifiers must not be valid email addresses. -- -- Since 1.2.0 type Identifier = Text -- | Data stored in a database for each e-mail address. data EmailCreds site = EmailCreds { emailCredsId :: AuthEmailId site , emailCredsAuthId :: Maybe (AuthId site) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey , emailCredsEmail :: Email } data ForgotPasswordForm = ForgotPasswordForm { forgotEmail :: Text } data PasswordForm = PasswordForm { passwordCurrent :: Text, passwordNew :: Text, passwordConfirm :: Text } data UserForm = UserForm { email :: 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) -- | Send an email to the given address to verify ownership. -- -- Since 1.1.0 sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () -- | Get the verification key for the given email ID. -- -- Since 1.1.0 getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) -- | Set the verification key for the given email ID. -- -- Since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () -- | Verify the email address on the given account. -- -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@ -- somewhere, this method should delete that key, or make it unusable -- in some fashion. Otherwise, the same key can be used multiple times! -- -- See . -- -- Since 1.1.0 verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) -- | Get the salted password for the given account. -- -- Since 1.1.0 getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) -- | Set the salted password for the given account. -- -- Since 1.1.0 setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () -- | 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)) -- | Get the email address for the given email ID. -- -- Since 1.1.0 getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) -- | Generate a random alphanumeric string. -- -- Since 1.1.0 randomKey :: site -> IO Text randomKey _ = Nonce.nonce128urlT defaultNonceGen -- | Route to send user to after password has been set correctly. -- -- Since 1.2.0 afterPasswordRoute :: site -> Route site -- | 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 needOldPassword aid' = do mkey <- lookupSession loginLinkKey case mkey >>= readMay . TS.unpack of Just (aidT, time) | Just aid <- fromPathPiece aidT, toPathPiece (aid `asTypeOf` aid') == toPathPiece aid' -> do now <- liftIO getCurrentTime return $ addUTCTime (60 * 30) time <= now _ -> return True -- | Check that the given plain-text password meets minimum security standards. -- -- Default: password is at least three characters. checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (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 TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender selectRep $ do provideJsonMessage (mr msg) provideRep $ authLayout $ do setTitleI Msg.ConfirmationEmailSentTitle [whamlet|

_{msg}|] where msg = Msg.ConfirmationEmailSent identifier -- | Additional normalization of email addresses, besides standard canonicalization. -- -- Default: Lower case the email address. -- -- Since 1.2.3 normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower -- | Handler called to render the registration page. The -- default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultRegisterHandler'. -- -- Since: 1.2.6. registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler -- | Handler called to render the \"forgot password\" page. -- The default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultForgotPasswordHandler'. -- -- Since: 1.2.6. forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler -- | Handler called to render the \"set password\" page. The -- default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultSetPasswordHandler'. -- -- Since: 1.2.6. setPasswordHandler :: Bool -- ^ Whether the old password is needed. If @True@, a -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed. -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler authEmail :: (YesodAuthEmail m) => AuthPlugin m authEmail = AuthPlugin "email" dispatch emailLoginHandler where 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 >>= 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 = registerHandler emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () emailLoginHandler toParent = do (widget, enctype) <- liftWidgetT $ generateFormPost loginForm [whamlet|

^{widget}