module Yesod.Auth
(
Auth
, AuthRoute
, Route (..)
, AuthPlugin (..)
, getAuth
, YesodAuth (..)
, YesodAuthPersist (..)
, Creds (..)
, setCreds
, setCredsRedirect
, clearCreds
, loginErrorMessage
, loginErrorMessageI
, AuthenticationResult (..)
, defaultMaybeAuthId
, defaultLoginHandler
, maybeAuthPair
, maybeAuth
, requireAuthId
, requireAuthPair
, requireAuth
, AuthException (..)
, MonadAuthHandler
, AuthHandler
, 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
data AuthenticationResult master
= Authenticated (AuthId master)
| UserError AuthMessage
| ServerError Text
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
data Creds master = Creds
{ credsPlugin :: Text
, credsIdent :: Text
, credsExtra :: [(Text, Text)]
} deriving (Show)
class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
type AuthId master
authLayout :: WidgetFor master () -> AuthHandler master Html
authLayout = liftHandler . defaultLayout
loginDest :: master -> Route master
logoutDest :: master -> Route master
authenticate :: Creds master -> AuthHandler master (AuthenticationResult master)
authenticate creds = do
muid <- getAuthId creds
return $ maybe (UserError Msg.InvalidLogin) Authenticated muid
getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master))
getAuthId creds = do
auth <- authenticate creds
return $ case auth of
Authenticated auid -> Just auid
_ -> Nothing
authPlugins :: master -> [AuthPlugin master]
loginHandler :: AuthHandler master Html
loginHandler = defaultLoginHandler
renderAuthMessage :: master
-> [Text]
-> AuthMessage
-> Text
renderAuthMessage _ _ = defaultMessage
redirectToReferer :: master -> Bool
redirectToReferer _ = False
redirectToCurrent :: master -> Bool
redirectToCurrent _ = True
authHttpManager :: AuthHandler master Manager
authHttpManager = liftIO getGlobalManager
onLogin :: AuthHandler master ()
onLogin = addMessageI "success" Msg.NowLoggedIn
onLogout :: AuthHandler master ()
onLogout = return ()
maybeAuthId :: AuthHandler master (Maybe (AuthId master))
default maybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
onErrorHtml :: Route master -> Text -> AuthHandler master Html
onErrorHtml dest msg = do
addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest
runHttpRequest
:: MonadAuthHandler master m
=> Request
-> (Response BodyReader -> m a)
-> m a
runHttpRequest req inner = do
man <- authHttpManager
withRunInIO $ \run -> withResponse req man $ run . inner
credsKey :: Text
credsKey = "_ID"
defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (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
-> AuthHandler master (Maybe (AuthEntity master))
cachedAuth
= fmap unCachedMaybeAuth
. cached
. fmap CachedMaybeAuth
. getAuthEntity
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
:: Route master
-> AuthMessage
-> AuthHandler master TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
loginErrorMessage
:: Route master
-> Text
-> AuthHandler master TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401
:: MonadAuthHandler master m
=> Text
-> m Html
-> m TypedContent
messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent
messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus
:: MonadAuthHandler master 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
:: Creds master
-> AuthHandler master 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 $
toWidget [whamlet|<h1>_{msg}|]
Just ar -> loginErrorMessageMasterI ar msg
ServerError msg -> do
$(logError) msg
case authRoute y of
Nothing -> do
msg' <- renderMessage' Msg.AuthError
messageJson500 msg' $ authLayout $
toWidget [whamlet|<h1>_{Msg.AuthError}|]
Just ar -> loginErrorMessageMasterI ar Msg.AuthError
where
renderMessage' msg = do
langs <- languages
master <- getYesod
return $ renderAuthMessage master langs msg
setCreds :: Bool
-> Creds master
-> AuthHandler master ()
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
else do auth <- authenticate creds
case auth of
Authenticated aid -> setSession credsKey $ toPathPiece aid
_ -> return ()
authLayoutJson
:: (ToJSON j, MonadAuthHandler master m)
=> WidgetFor master ()
-> m j
-> m TypedContent
authLayoutJson w json = selectRep $ do
provideRep $ authLayout w
provideRep $ fmap toJSON json
clearCreds :: Bool
-> AuthHandler master ()
clearCreds doRedirects = do
y <- getYesod
onLogout
deleteSession credsKey
when doRedirects $ do
redirectUltDest $ logoutDest y
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
<h1>Authentication Status
$maybe _ <- creds
<p>Logged in.
$nothing
<p>Not logged in.
|]
jsonCreds creds =
Object $ Map.fromList
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
setUltDestReferer' :: AuthHandler master ()
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
maybeAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => AuthHandler master (Maybe (Entity val))
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
maybeAuthPair
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (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 (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: AuthId master -> AuthHandler master (Maybe (AuthEntity master))
default getAuthEntity
:: ( YesodPersistBackend master ~ backend
, PersistRecordBackend (AuthEntity master) backend
, Key (AuthEntity master) ~ AuthId master
, PersistStore backend
)
=> AuthId master -> AuthHandler master (Maybe (AuthEntity master))
getAuthEntity = liftHandler . runDB . get
type family KeyEntity key
type instance KeyEntity (Key x) = x
requireAuthId :: AuthHandler master (AuthId master)
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
requireAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => AuthHandler master (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return
requireAuthPair
:: ( YesodAuthPersist master
, Typeable (AuthEntity master)
)
=> AuthHandler master (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: AuthHandler master a
handleAuthLack = do
aj <- acceptsJson
if aj then notAuthenticated else redirectLogin
redirectLogin :: AuthHandler master 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, Typeable)
instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth master where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html
asHtml = id