{-# 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 <- 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 -- (7 days)

-- Yesod

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
            -- `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 -> 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

popupLayout :: Widget -> Handler Html
popupLayout :: Widget -> HandlerFor App Markup
popupLayout 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")


-- 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 = 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
          -- 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 -> 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

-- session keys

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"

-- dbAuthPlugin

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)

-- 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 = (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