{-# LANGUAGE CPP #-}{-# LANGUAGE ConstraintKinds #-}{-# LANGUAGE DefaultSignatures #-}{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE DeriveDataTypeable #-}{-# OPTIONS_GHC -fno-warn-orphans #-}moduleYesod.Auth(-- * SubsiteAuth,AuthRoute,Route(..),AuthPlugin(..),getAuth,YesodAuth(..),YesodAuthPersist,AuthEntity-- * Plugin interface,Creds(..),setCreds,clearCreds,loginErrorMessage,loginErrorMessageI-- * User functions,defaultMaybeAuthId,maybeAuth,requireAuthId,requireAuth-- * Exception,AuthException(..)-- * Helper,AuthHandler-- * Internal,credsKey)whereimportControl.Monad(when)importControl.Monad.Trans.MaybeimportYesod.Auth.RoutesimportData.AesonimportData.Text.Encoding(decodeUtf8With)importData.Text.Encoding.Error(lenientDecode)importData.Text(Text)importqualifiedData.TextasTimportqualifiedData.HashMap.LazyasMapimportData.Monoid(Endo)importNetwork.HTTP.Conduit(Manager)importqualifiedNetwork.WaiasWimportText.Hamlet(shamlet)importYesod.CoreimportYesod.PersistimportYesod.Auth.Message(AuthMessage,defaultMessage)importqualifiedYesod.Auth.MessageasMsgimportYesod.Form(FormMessage)importData.Typeable(Typeable)importControl.Exception(Exception)importNetwork.HTTP.Types(unauthorized401)importControl.Monad.Trans.Resource(MonadResourceBase)importqualifiedControl.Monad.Trans.WriterasWritertypeAuthRoute=RouteAuthtypeAuthHandlermastera=YesodAuthmaster=>HandlerTAuth(HandlerTmasterIO)atypeMethod=TexttypePiece=TextdataAuthPluginmaster=AuthPlugin{apName::Text,apDispatch::Method->[Piece]->AuthHandlermaster(),apLogin::(RouteAuth->Routemaster)->WidgetTmasterIO()}getAuth::a->AuthgetAuth=constAuth-- | User credentialsdataCredsmaster=Creds{credsPlugin::Text-- ^ How the user was authenticated,credsIdent::Text-- ^ Identifier. Exact meaning depends on plugin.,credsExtra::[(Text,Text)]}class(Yesodmaster,PathPiece(AuthIdmaster),RenderMessagemasterFormMessage)=>YesodAuthmasterwheretypeAuthIdmaster-- | Default destination on successful login, if no other-- destination exists.loginDest::master->Routemaster-- | Default destination on successful logout, if no other-- destination exists.logoutDest::master->Routemaster-- | Determine the ID associated with the set of credentials.getAuthId::Credsmaster->HandlerTmasterIO(Maybe(AuthIdmaster))-- | Which authentication backends to use.authPlugins::master->[AuthPluginmaster]-- | What to show on the login page.loginHandler::AuthHandlermasterRepHtmlloginHandler=dotp<-getRouteToParentlift$defaultLayout$dosetTitleIMsg.LoginTitlemaster<-getYesodmapM_(flipapLogintp)(authPluginsmaster)-- | Used for i18n of messages provided by this package.renderAuthMessage::master->[Text]-- ^ languages->AuthMessage->TextrenderAuthMessage__=defaultMessage-- | After login and logout, redirect to the referring page, instead of-- 'loginDest' and 'logoutDest'. Default is 'False'.redirectToReferer::master->BoolredirectToReferer_=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-- @setMessageI NowLoggedIn@.onLogin::HandlerTmasterIO()onLogin=setMessageIMsg.NowLoggedIn-- | Called on logout. By default, does nothingonLogout::HandlerTmasterIO()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.0maybeAuthId::HandlerTmasterIO(Maybe(AuthIdmaster))defaultmaybeAuthId::(YesodAuthmaster,PersistMonadBackend(b(HandlerTmasterIO))~PersistEntityBackendval,b~YesodPersistBackendmaster,Keyval~AuthIdmaster,PersistStore(b(HandlerTmasterIO)),PersistEntityval,YesodPersistmaster,Typeableval)=>HandlerTmasterIO(Maybe(AuthIdmaster))maybeAuthId=defaultMaybeAuthId-- | Internal session key used to hold the authentication information.---- Since 1.2.3credsKey::TextcredsKey="_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.2defaultMaybeAuthId::(YesodAuthmaster,PersistMonadBackend(b(HandlerTmasterIO))~PersistEntityBackendval,b~YesodPersistBackendmaster,Keyval~AuthIdmaster,PersistStore(b(HandlerTmasterIO)),PersistEntityval,YesodPersistmaster,Typeableval)=>HandlerTmasterIO(Maybe(AuthIdmaster))defaultMaybeAuthId=doms<-lookupSessioncredsKeycasemsofNothing->returnNothingJusts->casefromPathPiecesofNothing->returnNothingJustaid->fmap(fmapentityKey)$cachedAuthaidcachedAuth::(YesodAuthmaster,PersistMonadBackend(b(HandlerTmasterIO))~PersistEntityBackendval,b~YesodPersistBackendmaster,Keyval~AuthIdmaster,PersistStore(b(HandlerTmasterIO)),PersistEntityval,YesodPersistmaster,Typeableval)=>AuthIdmaster->HandlerTmasterIO(Maybe(Entityval))cachedAuthaid=runMaybeT$doa<-MaybeT$fmapunCachedMaybeAuth$cached$fmapCachedMaybeAuth$runDB$getaidreturn$EntityaidaloginErrorMessageI::(MonadResourceBasem,YesodAuthmaster)=>Routechild->AuthMessage->HandlerTchild(HandlerTmasterm)aloginErrorMessageIdestmsg=dotoParent<-getRouteToParentlift$loginErrorMessageMasterI(toParentdest)msgloginErrorMessageMasterI::(YesodAuthmaster,MonadResourceBasem,RenderMessagemasterAuthMessage)=>Routemaster->AuthMessage->HandlerTmastermaloginErrorMessageMasterIdestmsg=domr<-getMessageRenderloginErrorMessagedest(mrmsg)-- | For HTML, set the message and redirect to the route.-- For JSON, send the message and a 401 statusloginErrorMessage::MonadResourceBasem=>Routesite->Text->HandlerTsitemaloginErrorMessagedestmsg=sendResponseStatusunauthorized401=<<(selectRep$doprovideRep$dosetMessage$toHtmlmsgfmapasHtml$redirectdestprovideJsonMessagemsg)whereasHtml::Html->HtmlasHtml=idprovideJsonMessage::Monadm=>Text->Writer.Writer(Endo[ProvidedRepm])()provideJsonMessagemsg=provideRep$return$object["message".=msg]-- | Sets user credentials for the session after checking them with authentication backends.setCreds::YesodAuthmaster=>Bool-- ^ if HTTP redirects should be done->Credsmaster-- ^ new credentials->HandlerTmasterIO()setCredsdoRedirectscreds=doy<-getYesodmaid<-getAuthIdcredscasemaidofNothing->whendoRedirects$docaseauthRouteyofNothing->dosendResponseStatusunauthorized401=<<(selectRep$doprovideRep$defaultLayout$toWidget[shamlet|<h1>Invalidlogin|]provideJsonMessage"Invalid Login")Justar->loginErrorMessageMasterIarMsg.InvalidLoginJustaid->dosetSessioncredsKey$toPathPieceaidwhendoRedirects$doonLoginres<-selectRep$doprovideRepTypetypeHtml$do_<-redirectUltDest$loginDestyreturn()provideJsonMessage"Login Successful"sendResponseres-- | Clears current user credentials for the session.---- Since 1.1.7clearCreds::YesodAuthmaster=>Bool-- ^ if HTTP redirect to 'logoutDest' should be done->HandlerTmasterIO()clearCredsdoRedirects=doy<-getYesoddeleteSessioncredsKeywhendoRedirects$doonLogoutredirectUltDest$logoutDestygetCheckR::AuthHandlermasterTypedContentgetCheckR=lift$docreds<-maybeAuthIddefaultLayoutJson(dosetTitle"Authentication Status"toWidget$html'creds)(return$jsonCredscreds)wherehtml'creds=[shamlet|$newlinenever<h1>AuthenticationStatus$maybe_<-creds<p>Loggedin.$nothing<p>Notloggedin.|]jsonCredscreds=Object$Map.fromList[(T.pack"logged_in",Bool$maybeFalse(constTrue)creds)]setUltDestReferer'::AuthHandlermaster()setUltDestReferer'=lift$domaster<-getYesodwhen(redirectToReferermaster)setUltDestReferergetLoginR::AuthHandlermasterRepHtmlgetLoginR=setUltDestReferer'>>loginHandlergetLogoutR::AuthHandlermaster()getLogoutR=setUltDestReferer'>>redirectToPostLogoutRpostLogoutR::AuthHandlermaster()postLogoutR=lift$clearCredsTruehandlePluginR::Text->[Text]->AuthHandlermaster()handlePluginRpluginpieces=domaster<-liftgetYesodenv<-waiRequestletmethod=decodeUtf8WithlenientDecode$W.requestMethodenvcasefilter(\x->apNamex==plugin)(authPluginsmaster)of[]->notFoundap:_->apDispatchapmethodpiecesmaybeAuth::(YesodAuthmaster,PersistMonadBackend(b(HandlerTmasterIO))~PersistEntityBackendval,b~YesodPersistBackendmaster,Keyval~AuthIdmaster,PersistStore(b(HandlerTmasterIO)),PersistEntityval,YesodPersistmaster,Typeableval)=>HandlerTmasterIO(Maybe(Entityval))maybeAuth=runMaybeT$doaid<-MaybeTmaybeAuthIdMaybeT$cachedAuthaidnewtypeCachedMaybeAuthval=CachedMaybeAuth{unCachedMaybeAuth::Maybeval}derivingTypeable-- | Constraint which states that the given site is an instance of @YesodAuth@-- and that its @AuthId@ is in fact a persistent @Key@ for the given value.-- This is the common case in Yesod, and means that you can easily look up the-- full informatin on a given user.---- Since 1.2.0typeYesodAuthPersistmaster=(YesodAuthmaster,PersistMonadBackend(YesodPersistBackendmaster(HandlerTmasterIO))~PersistEntityBackend(AuthEntitymaster),Key(AuthEntitymaster)~AuthIdmaster,PersistStore(YesodPersistBackendmaster(HandlerTmasterIO)),PersistEntity(AuthEntitymaster),YesodPersistmaster,Typeable(AuthEntitymaster))-- | 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.0typeAuthEntitymaster=KeyEntity(AuthIdmaster)-- | Similar to 'maybeAuthId', but redirects to a login page if user is not-- authenticated.---- Since 1.1.0requireAuthId::YesodAuthPersistmaster=>HandlerTmasterIO(AuthIdmaster)requireAuthId=maybeAuthId>>=mayberedirectLoginreturnrequireAuth::YesodAuthPersistmaster=>HandlerTmasterIO(Entity(AuthEntitymaster))requireAuth=maybeAuth>>=mayberedirectLoginreturnredirectLogin::Yesodmaster=>HandlerTmasterIOaredirectLogin=doy<-getYesodsetUltDestCurrentcaseauthRouteyofJustz->redirectzNothing->permissionDenied"Please configure authRoute"instanceYesodAuthmaster=>RenderMessagemasterAuthMessagewhererenderMessage=renderAuthMessagedataAuthException=InvalidFacebookResponsederiving(Show,Typeable)instanceExceptionAuthExceptioninstanceYesodAuthmaster=>YesodSubDispatchAuth(HandlerTmasterIO)whereyesodSubDispatch=$(mkYesodSubDispatchresourcesAuth)