{-# 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
, App -> ConnectionPool
appConnPool :: ConnectionPool
, App -> Manager
appHttpManager :: Manager
, App -> Logger
appLogger :: Logger
} deriving (Typeable)
mkYesodData "App" $(parseRoutesFile "config/routes")
deriving instance Typeable Route
deriving instance Generic (Route App)
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 <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
ReaderT SqlBackend (HandlerFor App) a
-> ConnectionPool -> HandlerFor App a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ReaderT SqlBackend (HandlerFor App) a
YesodDB App a
action (App -> ConnectionPool
appConnPool App
master)
instance YesodPersistRunner App where
getDBRunner :: HandlerFor App (DBRunner App, HandlerFor App ())
getDBRunner = (App -> ConnectionPool)
-> HandlerFor App (DBRunner App, HandlerFor App ())
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
instance Yesod App where
approot :: Approot App
approot = (App -> Request -> Text) -> Approot App
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 -> Approot App -> App -> Request -> Text
forall site. Approot site -> site -> Request -> Text
getApprootText Approot App
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 :: App -> AppSettings
appSettings :: 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 (IO (Maybe SessionBackend) -> IO (Maybe SessionBackend))
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
forall a b. (a -> b) -> a -> b
$ Maybe SessionBackend -> IO (Maybe SessionBackend)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionBackend -> Maybe SessionBackend
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 IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
forall a. a -> a
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 = HandlerFor App res -> HandlerFor App res
forall res. HandlerFor App res -> HandlerFor App res
customMiddleware (HandlerFor App res -> HandlerFor App res)
-> (HandlerFor App res -> HandlerFor App res)
-> HandlerFor App res
-> HandlerFor App res
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HandlerFor App res -> HandlerFor App res
forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware (HandlerFor App res -> HandlerFor App res)
-> (HandlerFor App res -> HandlerFor App res)
-> HandlerFor App res
-> HandlerFor App res
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HandlerFor App res -> HandlerFor App res
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 <- HandlerFor App (Maybe (Route (HandlerSite (HandlerFor App))))
HandlerFor App (Maybe (Route App))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
Bool
dontCheckCsrf <- case Maybe (Route App)
maybeRoute of
Just Route App
R:RouteApp
AddR -> Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> HandlerFor App (Maybe ByteString) -> HandlerFor App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> HandlerFor App (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"Authorization"
Maybe (Route App)
_ -> Bool -> HandlerFor App Bool
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(if Bool
dontCheckCsrf then HandlerFor App b -> HandlerFor App b
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else HandlerFor App b -> HandlerFor App b
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
Text -> Text -> HandlerFor App ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"X-Frame-Options" Text
"DENY"
App
yesod <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
(if AppSettings -> Bool
appSSLOnly (App -> AppSettings
appSettings App
yesod)
then Int -> HandlerFor App b -> HandlerFor App b
forall site res. Int -> HandlerFor site res -> HandlerFor site res
sslOnlyMiddleware Int
session_timeout_minutes
else HandlerFor App b -> HandlerFor App b
forall a. a -> a
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 <- HandlerFor App YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
App
master <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
Route App -> Text
urlrender <- HandlerFor App (Route (HandlerSite (HandlerFor App)) -> Text)
HandlerFor App (Route App -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
Maybe Markup
mmsg <- HandlerFor App (Maybe Markup)
forall (m :: * -> *). MonadHandler m => m (Maybe Markup)
getMessage
Maybe Text
musername <- Handler (Maybe Text)
maybeAuthUsername
Maybe User
muser <- ((Maybe (AuthId (HandlerSite (HandlerFor App)), User) -> Maybe User)
-> HandlerFor
App (Maybe (AuthId (HandlerSite (HandlerFor App)), User))
-> HandlerFor App (Maybe User)
forall a b. (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Maybe (AuthId (HandlerSite (HandlerFor App)), User)
-> Maybe User)
-> HandlerFor
App (Maybe (AuthId (HandlerSite (HandlerFor App)), User))
-> HandlerFor App (Maybe User))
-> (((AuthId (HandlerSite (HandlerFor App)), User) -> User)
-> Maybe (AuthId (HandlerSite (HandlerFor App)), User)
-> Maybe User)
-> ((AuthId (HandlerSite (HandlerFor App)), User) -> User)
-> HandlerFor
App (Maybe (AuthId (HandlerSite (HandlerFor App)), User))
-> HandlerFor App (Maybe User)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.((AuthId (HandlerSite (HandlerFor App)), User) -> User)
-> Maybe (AuthId (HandlerSite (HandlerFor App)), User)
-> Maybe User
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (AuthId (HandlerSite (HandlerFor App)), User) -> User
forall a b. (a, b) -> b
snd HandlerFor
App
(Maybe
(AuthId (HandlerSite (HandlerFor App)),
AuthEntity (HandlerSite (HandlerFor App))))
HandlerFor
App (Maybe (AuthId (HandlerSite (HandlerFor App)), User))
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 <- Widget -> HandlerFor App (PageContent (Route App))
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent do
Markup -> Widget
forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
"Espial"
Widget
forall (m :: * -> *). (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts
Route (HandlerSite (WidgetFor App)) -> Widget
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_tachyons_min_css)
Route (HandlerSite (WidgetFor App)) -> Widget
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_main_css)
$(widgetFile "default-layout")
((Route (HandlerSite (HandlerFor App)) -> [(Text, Text)] -> Text)
-> Markup)
-> HandlerFor App Markup
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 =
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ AppSettings -> Bool
appShouldLogAll (App -> AppSettings
appSettings App
app) Bool -> Bool -> Bool
|| LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LevelWarn Bool -> Bool -> Bool
|| LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LevelError
makeLogger :: App -> IO Logger
makeLogger = Logger -> IO Logger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> (App -> Logger) -> App -> IO Logger
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
_ = Route App -> Maybe (Route 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
_ = AuthResult -> HandlerFor App AuthResult
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult
Authorized
isAuthorized Route App
_ Bool
_ = AuthResult -> HandlerFor App AuthResult
forall a. a -> HandlerFor App a
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
Markup -> Widget
forall (m :: * -> *). MonadWidget m => Markup -> m ()
setTitle Markup
title
HtmlUrl (Route App) -> Widget
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ App) =>
HtmlUrl (Route App) -> m ()
toWidget HtmlUrl (Route App)
[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 = HandlerFor App (Maybe UserId)
HandlerFor App (Maybe (AuthId App))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
forall (m :: * -> *).
(MonadHandler m, App ~ HandlerSite m) =>
m (Maybe (AuthId App))
maybeAuthId HandlerFor App (Maybe UserId)
-> (Maybe UserId -> HandlerFor App AuthResult)
-> HandlerFor App AuthResult
forall a b.
HandlerFor App a -> (a -> HandlerFor App b) -> HandlerFor App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just UserId
authId -> AuthResult -> HandlerFor App AuthResult
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult
Authorized
Maybe UserId
_ -> AuthResult -> HandlerFor App AuthResult
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult -> HandlerFor App AuthResult)
-> AuthResult -> HandlerFor App AuthResult
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
Route (HandlerSite m) -> m ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route Static -> Route App
StaticR Route Static
js_app_min_js)
popupLayout :: Widget -> Handler Html
Widget
widget = do
YesodRequest
req <- HandlerFor App YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
App
master <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
Maybe Markup
mmsg <- HandlerFor App (Maybe Markup)
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 <- Widget -> HandlerFor App (PageContent (Route App))
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent do
Widget
forall (m :: * -> *). (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts
Route (HandlerSite (WidgetFor App)) -> Widget
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_tachyons_min_css)
Route (HandlerSite (WidgetFor App)) -> Widget
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route Static -> Route App
StaticR Route Static
css_popup_css)
$(widgetFile "popup-layout")
((Route (HandlerSite (HandlerFor App)) -> [(Text, Text)] -> Text)
-> Markup)
-> HandlerFor App Markup
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
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 = Creds App -> m (AuthenticationResult App)
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ App) =>
Creds App -> m (AuthenticationResult App)
authenticateCreds
loginDest :: App -> Route App
loginDest = Route App -> App -> Route App
forall a b. a -> b -> a
const Route App
HomeR
logoutDest :: App -> Route App
logoutDest = Route App -> App -> Route App
forall a b. a -> b -> a
const Route App
HomeR
onLogin :: forall (m :: * -> *). (MonadHandler m, App ~ HandlerSite m) => m ()
onLogin = m (Maybe (Entity User))
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 m (Maybe (Entity User)) -> (Maybe (Entity User) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Entity User)
Nothing -> Text -> m ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
cpprint (Text
"onLogin: could not find user" :: Text)
Just (Entity UserId
_ User
uname) -> Text -> Text -> m ()
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 =
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
userNameKey
redirectToReferer :: App -> Bool
redirectToReferer = Bool -> App -> Bool
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 <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
let mAuthHeader :: Maybe (MapValue RequestHeaders)
mAuthHeader = ContainerKey RequestHeaders
-> RequestHeaders -> Maybe (MapValue RequestHeaders)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup CI ByteString
ContainerKey RequestHeaders
"Authorization" (Request -> RequestHeaders
Wai.requestHeaders Request
req)
extractKey :: ByteString -> Maybe Text
extractKey = Text -> Text -> Maybe Text
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Maybe seq
stripPrefix Text
"ApiKey " (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 ByteString
MapValue RequestHeaders
authHeader of
Just Text
apiKey -> do
Maybe (Entity User)
user <- HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User))
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User)))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User))
forall a b. (a -> b) -> a -> b
$ YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
forall a. YesodDB (HandlerSite m) a -> HandlerFor (HandlerSite m) a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User)))
-> YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
forall a b. (a -> b) -> a -> b
$ ApiKey -> DB (Maybe (Entity User))
getApiKeyUser (Text -> ApiKey
ApiKey Text
apiKey)
let userId :: Maybe UserId
userId = Entity User -> UserId
forall record. Entity record -> Key record
entityKey (Entity User -> UserId) -> Maybe (Entity User) -> Maybe UserId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Entity User)
user
Maybe UserId -> m (Maybe UserId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserId
userId
Maybe Text
Nothing -> Maybe UserId -> m (Maybe UserId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserId
forall a. Maybe a
Nothing
Maybe (MapValue RequestHeaders)
_ -> m (Maybe UserId)
m (Maybe (AuthId App))
forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master,
Typeable (AuthEntity master)) =>
m (Maybe (AuthId master))
defaultMaybeAuthId
instance YesodAuthPersist App
maybeAuthUsername :: Handler (Maybe Text)
maybeAuthUsername :: Handler (Maybe Text)
maybeAuthUsername = do
Text -> Handler (Maybe Text)
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"
dbAuthPluginName :: Text
dbAuthPluginName :: Text
dbAuthPluginName = Text
"db"
dbAuthPlugin :: AuthPlugin App
dbAuthPlugin :: AuthPlugin App
dbAuthPlugin = Text
-> (Text -> [Text] -> AuthHandler App TypedContent)
-> ((Route Auth -> Route App) -> Widget)
-> AuthPlugin App
forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
dbAuthPluginName Text -> [Text] -> m TypedContent
Text -> [Text] -> AuthHandler App TypedContent
dbDispatch (Route Auth -> Route App) -> Widget
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"] = m TypedContent
forall master (m :: * -> *).
MonadAuthHandler master m =>
m TypedContent
dbPostLoginR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
dbDispatch Text
_ [Text]
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
dbLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
dbLoginHandler Route Auth -> Route site
toParent = do
YesodRequest
req <- WidgetFor site YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
Text -> WidgetFor site (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey WidgetFor site (Maybe Text)
-> (Maybe Text -> WidgetFor site ()) -> WidgetFor site ()
forall a b.
WidgetFor site a -> (a -> WidgetFor site b) -> WidgetFor site b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Text
dest | Text
"logout" Text -> Text -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isInfixOf` Text
dest -> Text -> WidgetFor site ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
ultDestKey
Maybe Text
_ -> () -> WidgetFor site ()
forall a. a -> WidgetFor site a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Markup -> WidgetFor site ()
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 (m :: * -> *).
MonadAuthHandler master m =>
m TypedContent
dbPostLoginR = do
FormResult (Creds master)
mresult <- FormInput m (Creds master) -> m (FormResult (Creds master))
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (Text -> Text -> Creds master
forall master. Text -> Text -> Creds master
dbLoginCreds
(Text -> Text -> Creds master)
-> FormInput m Text -> FormInput m (Text -> Creds master)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"username"
FormInput m (Text -> Creds master)
-> FormInput m Text -> FormInput m (Creds master)
forall a b. FormInput m (a -> b) -> FormInput m a -> FormInput m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password")
case FormResult (Creds master)
mresult of
FormSuccess Creds master
creds -> Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
Creds (HandlerSite m)
creds
FormResult (Creds master)
_ -> Route Auth -> AuthMessage -> AuthHandler master TypedContent
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
credsPlugin :: forall master. Creds master -> Text
credsIdent :: forall master. Creds master -> Text
credsExtra :: forall master. Creds master -> [(Text, Text)]
credsPlugin :: Text
credsIdent :: Text
credsExtra :: [(Text, Text)]
..} = do
Maybe (Entity User)
muser <-
case Text
credsPlugin of
Text
p | Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
dbAuthPluginName -> HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User))
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User)))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
-> m (Maybe (Entity User))
forall a b. (a -> b) -> a -> b
$ YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
forall a. YesodDB (HandlerSite m) a -> HandlerFor (HandlerSite m) a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User)))
-> YesodDB (HandlerSite m) (Maybe (Entity User))
-> HandlerFor (HandlerSite m) (Maybe (Entity User))
forall a b. (a -> b) -> a -> b
$
Maybe (Maybe (Entity User)) -> Maybe (Entity User)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Entity User)) -> Maybe (Entity User))
-> ReaderT
SqlBackend (HandlerFor App) (Maybe (Maybe (Entity User)))
-> SqlPersistT (HandlerFor App) (Maybe (Entity User))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> SqlPersistT (HandlerFor App) (Maybe (Entity User)))
-> Maybe Text
-> ReaderT
SqlBackend (HandlerFor App) (Maybe (Maybe (Entity User)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (\Text
pwd -> Text -> Text -> DB (Maybe (Entity User))
authenticatePassword Text
credsIdent Text
pwd) (ContainerKey [(Text, Text)]
-> [(Text, Text)] -> Maybe (MapValue [(Text, Text)])
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup Text
ContainerKey [(Text, Text)]
"password" [(Text, Text)]
credsExtra)
Text
_ -> Maybe (Entity User) -> m (Maybe (Entity User))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity User)
forall a. Maybe a
Nothing
case Maybe (Entity User)
muser of
Maybe (Entity User)
Nothing -> AuthenticationResult App -> m (AuthenticationResult App)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthMessage -> AuthenticationResult App
forall master. AuthMessage -> AuthenticationResult master
UserError AuthMessage
InvalidUsernamePass)
Just (Entity UserId
uid User
_) -> AuthenticationResult App -> m (AuthenticationResult App)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthId App -> AuthenticationResult App
forall master. AuthId master -> AuthenticationResult master
Authenticated UserId
AuthId App
uid)
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 = (App -> Logger) -> App -> HandlerFor App a -> IO a
forall site (m :: * -> *) a.
(Yesod site, MonadIO m) =>
(site -> Logger) -> site -> HandlerFor site a -> m a
Unsafe.fakeHandlerGetLogger App -> Logger
appLogger