yesod-auth-1.6.10/Yesod/0000755000000000000000000000000013620446540013136 5ustar0000000000000000yesod-auth-1.6.10/Yesod/Auth/0000755000000000000000000000000013636313625014043 5ustar0000000000000000yesod-auth-1.6.10/Yesod/Auth/Util/0000755000000000000000000000000013610641254014752 5ustar0000000000000000yesod-auth-1.6.10/Yesod/Auth.hs0000644000000000000000000005063413620446540014403 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# 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 , MonadAuthHandler , AuthHandler -- * Internal , credsKey , provideJsonMessage , messageJson401 , asHtml ) where import Control.Monad (when) import Control.Monad.Trans.Maybe import UnliftIO (withRunInIO, MonadUnliftIO) 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 Network.HTTP.Client.TLS (getGlobalManager) import qualified Network.Wai as W import Yesod.Core 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 qualified Control.Monad.Trans.Writer as Writer import Control.Monad (void) type AuthRoute = Route Auth type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m) type AuthHandler master a = forall m. MonadAuthHandler master m => m a type Method = Text type Piece = Text -- | The result of an authentication based on credentials -- -- @since 1.4.4 data AuthenticationResult master = Authenticated (AuthId master) -- ^ Authenticated successfully | UserError AuthMessage -- ^ Invalid credentials provided by user | ServerError Text -- ^ Some other error data AuthPlugin master = AuthPlugin { apName :: Text , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent , apLogin :: (Route Auth -> Route master) -> WidgetFor master () } 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)] } deriving (Show) class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where type AuthId master -- | specify the layout. Uses defaultLayout by default authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists. loginDest :: master -> Route master -- | 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 :: (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. -- -- 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 = 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 -- | 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 :: (MonadHandler m, HandlerSite m ~ master) => m Manager authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. onLogin :: (MonadHandler m, master ~ HandlerSite m) => m () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing onLogout :: (MonadHandler m, master ~ HandlerSite m) => m () 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 :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master)) default maybeAuthId :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master)) => m (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls -- @addMessage@ with "error" as status and redirects to @dest@. onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest -- | runHttpRequest gives you a chance to handle an HttpException and retry -- The default behavior is to simply execute the request which will throw an exception on failure -- -- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request. -- This is an experimental API that is not broadly used throughout the yesod-auth code base runHttpRequest :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m) => Request -> (Response BodyReader -> m a) -> m a runHttpRequest req inner = do man <- authHttpManager withRunInIO $ \run -> withResponse req man $ run . inner {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-} {-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-} -- | Internal session key used to hold the authentication information. -- -- @since 1.2.3 credsKey :: Text credsKey = "_ID" -- | Retrieves user credentials from the session, if user is authenticated. -- -- This function does /not/ confirm that the credentials are valid, see -- 'maybeAuthIdRaw' for more information. The first call in a request -- does a database request to make sure that the account is still in the database. -- -- @since 1.1.2 defaultMaybeAuthId :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master)) => m (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s _ <- MaybeT $ cachedAuth aid return aid cachedAuth :: ( MonadHandler m , YesodAuthPersist master , Typeable (AuthEntity master) , HandlerSite m ~ master ) => AuthId master -> m (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 authLayout $ do setTitleI Msg.LoginTitle master <- getYesod mapM_ (flip apLogin tp) (authPlugins master) loginErrorMessageI :: Route Auth -> AuthMessage -> AuthHandler master TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent loginErrorMessageMasterI (toParent dest) msg loginErrorMessageMasterI :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master) => Route master -> AuthMessage -> m TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status loginErrorMessage :: (MonadHandler m, YesodAuth (HandlerSite m)) => Route (HandlerSite m) -> Text -> m TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) messageJson401 :: MonadHandler m => Text -> m Html -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 messageJsonStatus :: MonadHandler m => Status -> Text -> m Html -> m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do let obj = object ["message" .= msg] void $ sendResponseStatus status obj return obj provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] setCredsRedirect :: (MonadHandler m, YesodAuth (HandlerSite m)) => Creds (HandlerSite m) -- ^ new credentials -> m TypedContent setCredsRedirect creds = do y <- getYesod 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 :: (MonadHandler m, YesodAuth (HandlerSite m)) => Bool -- ^ if HTTP redirects should be done -> Creds (HandlerSite m) -- ^ new credentials -> m () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds else do auth <- authenticate creds case auth of Authenticated aid -> setSession credsKey $ toPathPiece aid _ -> return () -- | same as defaultLayoutJson, but uses authLayout authLayoutJson :: (ToJSON j, MonadAuthHandler master m) => WidgetFor master () -- ^ HTML -> m j -- ^ JSON -> m TypedContent authLayoutJson w json = selectRep $ do provideRep $ authLayout w provideRep $ fmap toJSON json -- | Clears current user credentials for the session. -- -- @since 1.1.7 clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) => Bool -- ^ if HTTP, redirect to 'logoutDest' -> m () clearCreds doRedirects = do onLogout deleteSession credsKey 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 = 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' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m () setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer getLoginR :: AuthHandler master Html getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master () getLogoutR = do tp <- getRouteToParent setUltDestReferer' >> redirectToPost (tp LogoutR) postLogoutR :: AuthHandler master () postLogoutR = clearCreds True handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do master <- 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 , 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 ae <- MaybeT $ cachedAuth aid return (aid, ae) newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } -- | Class which states that the given site is an instance of @YesodAuth@ -- and that its @AuthId@ is a lookup key for the full user information in -- a @YesodPersist@ database. -- -- The default implementation of @getAuthEntity@ assumes that the @AuthId@ -- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the -- given value. This is the common case in Yesod, and means that you can -- easily look up the full information on a given user. -- -- @since 1.4.0 class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- | If the @AuthId@ for a given site is a persistent ID, this will give the -- value for that entity. E.g.: -- -- > type AuthId MySite = UserId -- > AuthEntity MySite ~ User -- -- @since 1.2.0 type AuthEntity master :: * type AuthEntity master = KeyEntity (AuthId master) getAuthEntity :: (MonadHandler m, HandlerSite m ~ master) => AuthId master -> m (Maybe (AuthEntity master)) default getAuthEntity :: ( YesodPersistBackend master ~ backend , PersistRecordBackend (AuthEntity master) backend , Key (AuthEntity master) ~ AuthId master , PersistStore backend , MonadHandler m , HandlerSite m ~ master ) => AuthId master -> m (Maybe (AuthEntity master)) getAuthEntity = liftHandler . runDB . get type family KeyEntity key type instance KeyEntity (Key x) = x -- | Similar to 'maybeAuthId', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- @since 1.1.0 requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m)) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- @since 1.1.0 requireAuth :: ( YesodAuthPersist master , val ~ AuthEntity master , Key val ~ AuthId master , PersistEntity val , Typeable val , MonadHandler m , HandlerSite m ~ master ) => m (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) , 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 when (redirectToCurrent y) 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 instance Exception AuthException instance YesodAuth master => YesodSubDispatch Auth master where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html asHtml = id yesod-auth-1.6.10/Yesod/Auth/BrowserId.hs0000644000000000000000000001307513610641254016277 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 audience <- case bisAudience of Just a -> return a Nothing -> do r <- getUrlRender 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 loginErrorMessage (tm LoginR) "BrowserID login error." Just email -> 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) -> WidgetFor master Text createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent render <- getUrlRender let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR) loginRoute = maybe (toMaster LoginR) id mOnRegistration toWidget [julius| function #{rawJS onclick}() { 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) -> WidgetFor master Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing yesod-auth-1.6.10/Yesod/Auth/Dummy.hs0000644000000000000000000000436613610641254015475 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Provides a dummy authentication module that simply lets a user specify -- their identifier. This is not intended for real world use, just for -- testing. This plugin supports form submissions via JSON (since 1.6.8). -- -- = Using the JSON Login Endpoint -- -- We are assuming that you have declared `authRoute` as follows -- -- @ -- Just $ AuthR LoginR -- @ -- -- If you are using a different one, then you have to adjust the -- endpoint accordingly. -- -- @ -- Endpoint: \/auth\/page\/dummy -- Method: POST -- JSON Data: { -- "ident": "my identifier" -- } -- @ -- -- Remember to add the following headers: -- -- - Accept: application\/json -- - Content-Type: application\/json module Yesod.Auth.Dummy ( authDummy ) where import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) import Yesod.Core import Data.Text (Text) import Data.Aeson.Types (Result(..), Parser) import qualified Data.Aeson.Types as A (parseEither, withObject) identParser :: Value -> Parser Text identParser = A.withObject "Ident" (.: "ident") authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where dispatch "POST" [] = do (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 = do request <- getRequest toWidget [hamlet| $newline never

$maybe t <- reqToken request Your new identifier is: # |] yesod-auth-1.6.10/Yesod/Auth/Email.hs0000644000000000000000000011133713636313625015434 0ustar0000000000000000{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | A Yesod plugin for Authentication via e-mail -- -- This plugin works out of the box by only setting a few methods on -- the type class that tell the plugin how to interoperate with your -- user data storage (your database). However, almost everything is -- customizeable by setting more methods on the type class. In -- addition, you can send all the form submissions via JSON and -- completely control the user's flow. -- -- This is a standard registration e-mail flow -- -- 1. A user registers a new e-mail address, and an e-mail is sent there -- 2. The user clicks on the registration link in the e-mail. Note that -- at this point they are actually logged in (without a -- password). That means that when they log out they will need to -- reset their password. -- 3. The user sets their password and is redirected to the site. -- 4. The user can now -- -- * logout and sign in -- * reset their password -- -- = Using JSON Endpoints -- -- We are assuming that you have declared auth route as follows -- -- @ -- /auth AuthR Auth getAuth -- @ -- -- If you are using a different route, then you have to adjust the -- endpoints accordingly. -- -- * Registration -- -- @ -- Endpoint: \/auth\/page\/email\/register -- Method: POST -- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" (optional) -- } -- @ -- -- * Forgot password -- -- @ -- Endpoint: \/auth\/page\/email\/forgot-password -- Method: POST -- JSON Data: { "email": "myemail@domain.com" } -- @ -- -- * Login -- -- @ -- Endpoint: \/auth\/page\/email\/login -- Method: POST -- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" -- } -- @ -- -- * Set new password -- -- @ -- Endpoint: \/auth\/page\/email\/set-password -- Method: POST -- JSON Data: { -- "new": "newPassword", -- "confirm": "newPassword", -- "current": "currentPassword" -- } -- @ -- -- Note that in the set password endpoint, the presence of the key -- "current" is dependent on how the 'needOldPassword' is defined in -- the instance for 'YesodAuthEmail'. module Yesod.Auth.Email ( -- * Plugin authEmail , YesodAuthEmail (..) , EmailCreds (..) , saltPass -- * Routes , loginR , registerR , forgotPasswordR , setpassR , verifyR , isValidPass -- * Types , Email , VerKey , VerUrl , SaltedPass , VerStatus , Identifier -- * Misc , loginLinkKey , setLoginLinkKey -- * Default handlers , defaultEmailLoginHandler , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler -- * Default helpers , defaultRegisterHelper ) where import Yesod.Auth import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form import qualified Yesod.Auth.Util.PasswordStore as PS import Control.Applicative ((<$>), (<*>)) import qualified Crypto.Hash 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 import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) import Data.Maybe (isJust) import Data.ByteArray (convert) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] registerR = PluginR "email" ["register"] forgotPasswordR = PluginR "email" ["forgot-password"] setpassR = PluginR "email" ["set-password"] verifyURLHasSetPassText :: Text verifyURLHasSetPassText = "has-set-pass" -- | -- -- @since 1.4.5 verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME verifyR eid verkey hasSetPass = PluginR "email" path where path = "verify":eid:verkey:(if hasSetPass then [verifyURLHasSetPassText] else []) type Email = Text type VerKey = Text type VerUrl = Text type SaltedPass = Text type VerStatus = Bool -- | An Identifier generalizes an email address to allow users to log in with -- some other form of credentials (e.g., username). -- -- Note that any of these other identifiers must not be valid email addresses. -- -- @since 1.2.0 type Identifier = Text -- | Data stored in a database for each e-mail address. data EmailCreds site = EmailCreds { emailCredsId :: AuthEmailId site , emailCredsAuthId :: Maybe (AuthId site) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey , emailCredsEmail :: Email } data ForgotPasswordForm = ForgotPasswordForm { _forgotEmail :: Text } data PasswordForm = PasswordForm { _passwordCurrent :: Text, _passwordNew :: Text, _passwordConfirm :: Text } data UserForm = UserForm { _userFormEmail :: Text } data UserLoginForm = UserLoginForm { _loginEmail :: Text, _loginPassword :: Text } class ( YesodAuth site , PathPiece (AuthEmailId site) , (RenderMessage site Msg.AuthMessage) ) => YesodAuthEmail site where type AuthEmailId site -- | Add a new email address to the database, but indicate that the address -- has not yet been verified. -- -- @since 1.1.0 addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site) -- | Similar to `addUnverified`, but comes with the registered password. -- -- The default implementation is just `addUnverified`, which ignores the password. -- -- You may override this to save the salted password to your database. -- -- @since 1.6.4 addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site) addUnverifiedWithPass email verkey _ = addUnverified email verkey -- | Send an email to the given address to verify ownership. -- -- @since 1.1.0 sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site () -- | Send an email to the given address to re-verify ownership in the case of -- a password reset. This can be used to send a different email when a user -- goes through the 'forgot password' flow as opposed to the 'account registration' -- flow. -- -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent -- for both registrations and password resets. -- -- @since 1.6.10 sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site () sendForgotPasswordEmail = sendVerifyEmail -- | Get the verification key for the given email ID. -- -- @since 1.1.0 getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey) -- | Set the verification key for the given email ID. -- -- @since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site () -- | Hash and salt a password -- -- Default: 'saltPass'. -- -- @since 1.4.20 hashAndSaltPassword :: Text -> AuthHandler site SaltedPass hashAndSaltPassword = liftIO . saltPass -- | Verify a password matches the stored password for the given account. -- -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'. -- -- @since 1.4.20 verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool verifyPassword plain salted = return $ isValidPass plain salted -- | Verify the email address on the given account. -- -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@ -- somewhere, this method should delete that key, or make it unusable -- in some fashion. Otherwise, the same key can be used multiple times! -- -- See . -- -- @since 1.1.0 verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site)) -- | Get the salted password for the given account. -- -- @since 1.1.0 getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass) -- | Set the salted password for the given account. -- -- @since 1.1.0 setPassword :: AuthId site -> SaltedPass -> AuthHandler site () -- | Get the credentials for the given @Identifier@, which may be either an -- email address or some other identification (e.g., username). -- -- @since 1.2.0 getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site)) -- | Get the email address for the given email ID. -- -- @since 1.1.0 getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email) -- | Generate a random alphanumeric string. -- -- @since 1.1.0 randomKey :: site -> IO VerKey randomKey _ = Nonce.nonce128urlT defaultNonceGen -- | Route to send user to after password has been set correctly. -- -- @since 1.2.0 afterPasswordRoute :: site -> Route site -- | Route to send user to after verification with a password -- -- @since 1.6.4 afterVerificationWithPass :: site -> Route site afterVerificationWithPass = afterPasswordRoute -- | Does the user need to provide the current password in order to set a -- new password? -- -- Default: if the user logged in via an email link do not require a password. -- -- @since 1.2.1 needOldPassword :: AuthId site -> AuthHandler site Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey case mkey >>= readMay . TS.unpack of Just (aidT, time) | Just aid <- fromPathPiece aidT, toPathPiece (aid `asTypeOf` aid') == toPathPiece aid' -> do now <- liftIO getCurrentTime return $ addUTCTime (60 * 30) time <= now _ -> return True -- | Check that the given plain-text password meets minimum security standards. -- -- Default: password is at least three characters. checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ()) checkPasswordSecurity _ x | TS.length x >= 3 = return $ Right () | otherwise = return $ Left "Password must be at least three characters" -- | Response after sending a confirmation email. -- -- @since 1.2.2 confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender selectRep $ do provideJsonMessage (mr msg) provideRep $ authLayout $ do setTitleI Msg.ConfirmationEmailSentTitle [whamlet|

_{msg}|] where msg = Msg.ConfirmationEmailSent identifier -- | If a response is set, it will be used when an already-verified email -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be -- used. -- -- @since 1.6.4 emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent) emailPreviouslyRegisteredResponse _ = Nothing -- | Additional normalization of email addresses, besides standard canonicalization. -- -- Default: Lower case the email address. -- -- @since 1.2.3 normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower -- | Handler called to render the login page. -- The default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultEmailLoginHandler'. -- -- @since 1.4.17 emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site () emailLoginHandler = defaultEmailLoginHandler -- | Handler called to render the registration page. The -- default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultRegisterHandler'. -- -- @since: 1.2.6 registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler -- | Handler called to render the \"forgot password\" page. -- The default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultForgotPasswordHandler'. -- -- @since: 1.2.6 forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler -- | Handler called to render the \"set password\" page. The -- default works fine, but you may want to override it in -- order to have a different DOM. -- -- Default: 'defaultSetPasswordHandler'. -- -- @since: 1.2.6 setPasswordHandler :: Bool -- ^ Whether the old password is needed. If @True@, a -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed. -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler -- | Helper that controls what happens after a user registration -- request is submitted. This method can be overridden to completely -- customize what happens during the user registration process, -- such as for handling additional fields in the registration form. -- -- The default implementation is in terms of 'defaultRegisterHelper'. -- -- @since: 1.6.9 registerHelper :: Route Auth -- ^ Where to sent the user in the event -- that registration fails -> AuthHandler site TypedContent registerHelper = defaultRegisterHelper False False -- | Helper that controls what happens after a forgot password -- request is submitted. As with `registerHelper`, this method can -- be overridden to customize the behavior when a user attempts -- to recover their password. -- -- The default implementation is in terms of 'defaultRegisterHelper'. -- -- @since: 1.6.9 passwordResetHelper :: Route Auth -- ^ Where to sent the user in the event -- that the password reset fails -> AuthHandler site TypedContent passwordResetHelper = defaultRegisterHelper True True authEmail :: (YesodAuthEmail m) => AuthPlugin m authEmail = AuthPlugin "email" dispatch emailLoginHandler where dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of Nothing -> notFound Just eid' -> getVerifyR eid' verkey False >>= sendResponse dispatch "GET" ["verify", eid, verkey, hasSetPass] = case fromPathPiece eid of Nothing -> notFound Just eid' -> getVerifyR eid' verkey (hasSetPass == verifyURLHasSetPassText) >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch _ _ = notFound getRegisterR :: YesodAuthEmail master => AuthHandler master Html getRegisterR = registerHandler -- | Default implementation of 'emailLoginHandler'. -- -- @since 1.4.17 defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetFor master () defaultEmailLoginHandler toParent = do (widget, enctype) <- generateFormPost loginForm [whamlet|

^{widget}