{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}

module Foundation where

import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet          (hamletFile)
import PathPiece()

import Yesod.Core.Types
import Yesod.Auth.Message
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import qualified Yesod.Core.Unsafe as Unsafe
import qualified Network.Wai as Wai

data App = App
    { App -> AppSettings
appSettings    :: AppSettings
    , App -> Static
appStatic      :: Static -- ^ Settings for static file serving.
    , App -> ConnectionPool
appConnPool    :: ConnectionPool -- ^ Database connection pool.
    , App -> Manager
appHttpManager :: Manager
    , App -> Logger
appLogger      :: Logger
    } deriving (Typeable)

mkYesodData "App" $(parseRoutesFile "config/routes")

deriving instance Typeable Route 
deriving instance Generic (Route App)

-- YesodPersist

instance YesodPersist App where
    type YesodPersistBackend App = SqlBackend
    runDB :: forall a. YesodDB App a -> HandlerFor App a
runDB YesodDB App a
action = do
        App
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool YesodDB App a
action (App -> ConnectionPool
appConnPool App
master)

instance YesodPersistRunner App where
    getDBRunner :: HandlerFor App (DBRunner App, HandlerFor App ())
getDBRunner = forall backend site.
(IsSqlBackend backend, YesodPersistBackend site ~ backend) =>
(site -> Pool backend)
-> HandlerFor site (DBRunner site, HandlerFor site ())
defaultGetDBRunner App -> ConnectionPool
appConnPool

session_timeout_minutes :: Int
session_timeout_minutes :: Int
session_timeout_minutes = Int
10080 -- (7 days)

-- Yesod

instance Yesod App where
    approot :: Approot App
approot = forall master. (master -> Request -> Text) -> Approot master
ApprootRequest \App
app Request
req ->
        case AppSettings -> Maybe Text
appRoot (App -> AppSettings
appSettings App
app) of
            Maybe Text
Nothing -> forall site. Approot site -> site -> Request -> Text
getApprootText forall site. Approot site
guessApproot App
app Request
req
            Just Text
root -> Text
root

    makeSessionBackend :: App -> IO (Maybe SessionBackend)
    makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend App {AppSettings
appSettings :: AppSettings
appSettings :: App -> AppSettings
appSettings} = do
      SessionBackend
backend <-
        Int -> String -> IO SessionBackend
defaultClientSessionBackend
          Int
session_timeout_minutes
          String
"config/client_session_key.aes"
      IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
maybeSSLOnly forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just SessionBackend
backend)
      where
        maybeSSLOnly :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
maybeSSLOnly =
          if AppSettings -> Bool
appSSLOnly AppSettings
appSettings
            then IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sslOnlySessions
            else forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

    yesodMiddleware :: HandlerFor App res -> HandlerFor App res
    yesodMiddleware :: forall res. HandlerFor App res -> HandlerFor App res
yesodMiddleware = forall res. HandlerFor App res -> HandlerFor App res
customMiddleware forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall res. HandlerFor App res -> HandlerFor App res
customCsrfMiddleware
      where
        customCsrfMiddleware :: HandlerFor App b -> HandlerFor App b
customCsrfMiddleware HandlerFor App b
handler = do
          Maybe (Route App)
maybeRoute <- forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
          Bool
dontCheckCsrf <- case Maybe (Route App)
maybeRoute of
            -- `maybeAuthId` checks for the validity of the Authorization
            -- header anyway, but it is still a good idea to limit this
            -- flexibility to designated routes.
            -- For the time being, `AddR` is the only route that accepts an
            -- authentication token.
            Just Route App
R:RouteApp
AddR -> forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"Authorization"
            Maybe (Route App)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          (if Bool
dontCheckCsrf then forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware) HandlerFor App b
handler

        customMiddleware :: HandlerFor App b -> HandlerFor App b
customMiddleware HandlerFor App b
handler = do
          forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"X-Frame-Options" Text
"DENY"
          App
yesod <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
          (if AppSettings -> Bool
appSSLOnly (App -> AppSettings
appSettings App
yesod)
             then forall site res. Int -> HandlerFor site res -> HandlerFor site res
sslOnlyMiddleware Int
session_timeout_minutes
             else forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) HandlerFor App b
handler

    defaultLayout :: Widget -> HandlerFor App Markup
defaultLayout Widget
widget = do
        YesodRequest
req <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
        App
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        Route App -> Text
urlrender <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        Maybe Markup
mmsg <- forall (m :: * -> *). MonadHandler m => m (Maybe Markup)
getMessage
        Maybe Text
musername <- Handler (Maybe Text)
maybeAuthUsername
        Maybe User
muser <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a b. (a, b) -> b
snd forall master (m :: * -> *).
(YesodAuthPersist master, Typeable (AuthEntity master),
 MonadHandler m, HandlerSite m ~ master) =>
m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair
        let msourceCodeUri :: Maybe Text
msourceCodeUri = AppSettings -> Maybe Text
appSourceCodeUri (App -> AppSettings
appSettings App
master)
        PageContent (Route App)
pc <- forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent do
            forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
"Espial"
            forall (m :: * -> *). (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts
            forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_tachyons_min_css)
            forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_main_css)
            $(widgetFile "default-layout")
        forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

    shouldLogIO :: App -> Text -> LogLevel -> IO Bool
shouldLogIO App
app Text
_source LogLevel
level =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AppSettings -> Bool
appShouldLogAll (App -> AppSettings
appSettings App
app) Bool -> Bool -> Bool
|| LogLevel
level forall a. Eq a => a -> a -> Bool
== LogLevel
LevelWarn Bool -> Bool -> Bool
|| LogLevel
level forall a. Eq a => a -> a -> Bool
== LogLevel
LevelError
    makeLogger :: App -> IO Logger
makeLogger = forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. App -> Logger
appLogger

    authRoute :: App -> Maybe (Route App)
authRoute App
_ = forall a. a -> Maybe a
Just (Route Auth -> Route App
AuthR Route Auth
LoginR)

    isAuthorized :: Route App -> Bool -> HandlerFor App AuthResult
isAuthorized (AuthR Route Auth
_) Bool
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult
Authorized
    isAuthorized Route App
_ Bool
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult
Authorized

    defaultMessageWidget :: Markup -> HtmlUrl (Route App) -> Widget
defaultMessageWidget Markup
title HtmlUrl (Route App)
body = do
      forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
title
      forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
        <main .pv2.ph3.mh1>
          <div .w-100.mw8.center>
            <div .pa3.bg-near-white>
              <h1>#{title}
              ^{body}
      |]


isAuthenticated :: Handler AuthResult
isAuthenticated :: HandlerFor App AuthResult
isAuthenticated = forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Just Key User
authId -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult
Authorized
                    Maybe (Key User)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AuthResult
AuthenticationRequired

addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts :: forall (m :: * -> *). (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts = do
  forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route Static -> Route App
StaticR Route Static
js_app_min_js) 


-- popupLayout

popupLayout :: Widget -> Handler Html
popupLayout :: Widget -> HandlerFor App Markup
popupLayout Widget
widget = do
    YesodRequest
req <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    App
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Maybe Markup
mmsg <- forall (m :: * -> *). MonadHandler m => m (Maybe Markup)
getMessage
    Maybe Text
musername <- Handler (Maybe Text)
maybeAuthUsername
    let msourceCodeUri :: Maybe Text
msourceCodeUri = AppSettings -> Maybe Text
appSourceCodeUri (App -> AppSettings
appSettings App
master)
    PageContent (Route App)
pc <- forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent do
      forall (m :: * -> *). (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts
      forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_tachyons_min_css)
      forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_popup_css)
      $(widgetFile "popup-layout")
    forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")


-- YesodAuth

instance YesodAuth App where
  type AuthId App = UserId
  authPlugins :: App -> [AuthPlugin App]
authPlugins App
_ = [AuthPlugin App
dbAuthPlugin]
  authenticate :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ App) =>
Creds App -> m (AuthenticationResult App)
authenticate = forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ App) =>
Creds App -> m (AuthenticationResult App)
authenticateCreds
  loginDest :: App -> Route App
loginDest = forall a b. a -> b -> a
const Route App
HomeR
  logoutDest :: App -> Route App
logoutDest = forall a b. a -> b -> a
const Route App
HomeR
  onLogin :: forall (m :: * -> *). (MonadHandler m, App ~ HandlerSite m) => m ()
onLogin = forall master val (m :: * -> *).
(YesodAuthPersist master, val ~ AuthEntity master,
 Key val ~ AuthId master, PersistEntity val, Typeable val,
 MonadHandler m, HandlerSite m ~ master) =>
m (Maybe (Entity val))
maybeAuth forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Entity User)
Nothing -> forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
cpprint (Text
"onLogin: could not find user" :: Text)
    Just (Entity Key User
_ User
uname) -> forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
userNameKey (User -> Text
userName User
uname)
  onLogout :: forall (m :: * -> *). (MonadHandler m, App ~ HandlerSite m) => m ()
onLogout =
    forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
userNameKey
  redirectToReferer :: App -> Bool
redirectToReferer = forall a b. a -> b -> a
const Bool
True
  maybeAuthId :: forall (m :: * -> *).
(MonadHandler m, App ~ HandlerSite m) =>
m (Maybe (AuthId App))
maybeAuthId = do
    Request
req <- forall (m :: * -> *). MonadHandler m => m Request
waiRequest
    let mAuthHeader :: Maybe (MapValue RequestHeaders)
mAuthHeader = forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup CI ByteString
"Authorization" (Request -> RequestHeaders
Wai.requestHeaders Request
req)
        extractKey :: ByteString -> Maybe Text
extractKey = forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Maybe seq
stripPrefix Text
"ApiKey " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
TE.decodeUtf8
    case Maybe (MapValue RequestHeaders)
mAuthHeader of
      Just MapValue RequestHeaders
authHeader ->
        case ByteString -> Maybe Text
extractKey MapValue RequestHeaders
authHeader of
          Just Text
apiKey -> do
            Maybe (Entity User)
user <- forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler forall a b. (a -> b) -> a -> b
$ forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$ ApiKey -> DB (Maybe (Entity User))
getApiKeyUser (Text -> ApiKey
ApiKey Text
apiKey)
            let userId :: Maybe (Key User)
userId = forall record. Entity record -> Key record
entityKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Entity User)
user
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Key User)
userId
          -- Since we disable CSRF middleware in the presence of Authorization
          -- header, we need to explicitly check for the validity of the header
          -- content. Otherwise, a dummy Authorization header with garbage input
          -- could be provided to circumvent CSRF token requirement, making the app
          -- vulnerable to CSRF attacks.
          Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Maybe (MapValue RequestHeaders)
_ -> forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master,
 Typeable (AuthEntity master)) =>
m (Maybe (AuthId master))
defaultMaybeAuthId

instance YesodAuthPersist App

-- session keys

maybeAuthUsername :: Handler (Maybe Text)
maybeAuthUsername :: Handler (Maybe Text)
maybeAuthUsername = do
  forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
userNameKey

ultDestKey :: Text
ultDestKey :: Text
ultDestKey = Text
"_ULT"

userNameKey :: Text
userNameKey :: Text
userNameKey = Text
"_UNAME"

-- dbAuthPlugin

dbAuthPluginName :: Text
dbAuthPluginName :: Text
dbAuthPluginName = Text
"db"

dbAuthPlugin :: AuthPlugin App
dbAuthPlugin :: AuthPlugin App
dbAuthPlugin = forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
dbAuthPluginName Text -> [Text] -> AuthHandler App TypedContent
dbDispatch forall {site}. (Route Auth -> Route site) -> WidgetFor site ()
dbLoginHandler
  where
    dbDispatch :: Text -> [Text] -> AuthHandler App TypedContent
    dbDispatch :: Text -> [Text] -> AuthHandler App TypedContent
dbDispatch Text
"POST" [Text
"login"] = forall master. AuthHandler master TypedContent
dbPostLoginR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dbDispatch Text
_ [Text]
_ = forall (m :: * -> *) a. MonadHandler m => m a
notFound
    dbLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
dbLoginHandler Route Auth -> Route site
toParent = do
      YesodRequest
req <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
      forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Text
dest | Text
"logout" forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isInfixOf` Text
dest -> forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
ultDestKey
        Maybe Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
"Espial | Log In"
      $(widgetFile "login")

dbLoginR :: AuthRoute
dbLoginR :: Route Auth
dbLoginR = Text -> [Text] -> Route Auth
PluginR Text
dbAuthPluginName [Text
"login"]

dbPostLoginR ::  AuthHandler master TypedContent
dbPostLoginR :: forall master. AuthHandler master TypedContent
dbPostLoginR = do
  FormResult (Creds master)
mresult <- forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (forall master. Text -> Text -> Creds master
dbLoginCreds
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"username"
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password")
  case FormResult (Creds master)
mresult of
    FormSuccess Creds master
creds -> forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
creds
    FormResult (Creds master)
_ -> forall master.
Route Auth -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI Route Auth
LoginR AuthMessage
InvalidUsernamePass

dbLoginCreds :: Text -> Text -> Creds master
dbLoginCreds :: forall master. Text -> Text -> Creds master
dbLoginCreds Text
username Text
password =
  Creds
  { credsPlugin :: Text
credsPlugin = Text
dbAuthPluginName
  , credsIdent :: Text
credsIdent = Text
username
  , credsExtra :: [(Text, Text)]
credsExtra = [(Text
"password", Text
password)]
  }

authenticateCreds ::
     (MonadHandler m, HandlerSite m ~ App)
  => Creds App
  -> m (AuthenticationResult App)
authenticateCreds :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ App) =>
Creds App -> m (AuthenticationResult App)
authenticateCreds Creds {[(Text, Text)]
Text
credsExtra :: [(Text, Text)]
credsIdent :: Text
credsPlugin :: Text
credsExtra :: forall master. Creds master -> [(Text, Text)]
credsIdent :: forall master. Creds master -> Text
credsPlugin :: forall master. Creds master -> Text
..} = do
  Maybe (Entity User)
muser <-
    case Text
credsPlugin of
      Text
p | Text
p forall a. Eq a => a -> a -> Bool
== Text
dbAuthPluginName -> forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler forall a b. (a -> b) -> a -> b
$ forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
pwd -> Text -> Text -> DB (Maybe (Entity User))
authenticatePassword Text
credsIdent Text
pwd) (forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup Text
"password" [(Text, Text)]
credsExtra)
      Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  case Maybe (Entity User)
muser of
    Maybe (Entity User)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall master. AuthMessage -> AuthenticationResult master
UserError AuthMessage
InvalidUsernamePass)
    Just (Entity Key User
uid User
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall master. AuthId master -> AuthenticationResult master
Authenticated Key User
uid)

-- Util

instance RenderMessage App FormMessage where
    renderMessage :: App -> [Lang] -> FormMessage -> Text
    renderMessage :: App -> [Text] -> FormMessage -> Text
renderMessage App
_ [Text]
_ = FormMessage -> Text
defaultFormMessage

instance HasHttpManager App where
    getHttpManager :: App -> Manager
    getHttpManager :: App -> Manager
getHttpManager = App -> Manager
appHttpManager

unsafeHandler :: App -> Handler a -> IO a
unsafeHandler :: forall a. App -> Handler a -> IO a
unsafeHandler = forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
(site -> Logger) -> site -> HandlerFor site a -> m a
Unsafe.fakeHandlerGetLogger App -> Logger
appLogger