{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.HashDB
( HashDBUser(..)
, defaultStrength
, setPasswordStrength
, setPassword
, validatePass
, upgradePasswordHash
, validateUser
, authHashDB
, authHashDBWithForm
, submitRouteHashDB
) where
import Yesod.Auth.Util.PasswordStore (makePassword, strengthenPassword,
verifyPassword, passwordStrength)
import Data.Aeson ((.:?))
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Yesod.Auth
import qualified Yesod.Auth.Message as Msg
import Yesod.Core
import Yesod.Form
import Yesod.Persist
#if !MIN_VERSION_yesod_core(1,6,0)
type HandlerFor site a = HandlerT site IO a
type WidgetFor site a = WidgetT site IO ()
#define liftHandler lift
#endif
#if !MIN_VERSION_yesod_core(1,6,11)
#define requireInsecureJsonBody requireJsonBody
#endif
defaultStrength :: Int
defaultStrength :: Int
defaultStrength = Int
17
class HashDBUser user where
userPasswordHash :: user -> Maybe Text
setPasswordHash :: Text
-> user -> user
{-# MINIMAL userPasswordHash, setPasswordHash #-}
passwordHash :: MonadIO m => Int -> Text -> m Text
passwordHash :: Int -> Text -> m Text
passwordHash Int
strength Text
pwd = do
ByteString
h <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> IO ByteString
makePassword (String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
pwd) Int
strength
Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
h
setPasswordStrength :: (MonadIO m, HashDBUser user) => Int -> Text -> user -> m user
setPasswordStrength :: Int -> Text -> user -> m user
setPasswordStrength Int
strength Text
pwd user
u = do
Text
hashed <- Int -> Text -> m Text
forall (m :: * -> *). MonadIO m => Int -> Text -> m Text
passwordHash Int
strength Text
pwd
user -> m user
forall (m :: * -> *) a. Monad m => a -> m a
return (user -> m user) -> user -> m user
forall a b. (a -> b) -> a -> b
$ Text -> user -> user
forall user. HashDBUser user => Text -> user -> user
setPasswordHash Text
hashed user
u
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
setPassword :: Text -> user -> m user
setPassword = Int -> Text -> user -> m user
forall (m :: * -> *) user.
(MonadIO m, HashDBUser user) =>
Int -> Text -> user -> m user
setPasswordStrength Int
defaultStrength
validatePass :: HashDBUser u => u -> Text -> Maybe Bool
validatePass :: u -> Text -> Maybe Bool
validatePass u
user Text
passwd = do
Text
hash <- u -> Maybe Text
forall user. HashDBUser user => user -> Maybe Text
userPasswordHash u
user
let hash' :: ByteString
hash' = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
hash
passwd' :: ByteString
passwd' = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
passwd
if ByteString -> Int
passwordStrength ByteString
hash' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Bool
verifyPassword ByteString
passwd' ByteString
hash'
else Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
upgradePasswordHash :: (MonadIO m, HashDBUser user) => Int -> user -> m (Maybe user)
upgradePasswordHash :: Int -> user -> m (Maybe user)
upgradePasswordHash Int
strength user
u = do
let old :: Maybe Text
old = user -> Maybe Text
forall user. HashDBUser user => user -> Maybe Text
userPasswordHash user
u
case Maybe Text
old of
Just Text
oldHash -> do
let oldHash' :: ByteString
oldHash' = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
oldHash
if ByteString -> Int
passwordStrength ByteString
oldHash' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then
let newHash :: Text
newHash = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteString
strengthenPassword ByteString
oldHash' Int
strength
in Maybe user -> m (Maybe user)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe user -> m (Maybe user)) -> Maybe user -> m (Maybe user)
forall a b. (a -> b) -> a -> b
$ user -> Maybe user
forall a. a -> Maybe a
Just (user -> Maybe user) -> user -> Maybe user
forall a b. (a -> b) -> a -> b
$ Text -> user -> user
forall user. HashDBUser user => Text -> user -> user
setPasswordHash Text
newHash user
u
else do
Maybe user -> m (Maybe user)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe user
forall a. Maybe a
Nothing
Maybe Text
Nothing -> Maybe user -> m (Maybe user)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe user
forall a. Maybe a
Nothing
type HashDBPersist master user =
( YesodAuthPersist master
, PersistUnique (YesodPersistBackend master)
, AuthEntity master ~ user
#if MIN_VERSION_persistent(2,5,0)
, PersistEntityBackend user ~ BaseBackend (YesodPersistBackend master)
#else
, PersistEntityBackend user ~ YesodPersistBackend master
#endif
, HashDBUser user
, PersistEntity user
)
data UserPass = UserPass (Maybe Text) (Maybe Text)
instance FromJSON UserPass where
parseJSON :: Value -> Parser UserPass
parseJSON (Object Object
v) = Maybe Text -> Maybe Text -> UserPass
UserPass (Maybe Text -> Maybe Text -> UserPass)
-> Parser (Maybe Text) -> Parser (Maybe Text -> UserPass)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"username" Parser (Maybe Text -> UserPass)
-> Parser (Maybe Text) -> Parser UserPass
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"password"
parseJSON Value
_ = UserPass -> Parser UserPass
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserPass -> Parser UserPass) -> UserPass -> Parser UserPass
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Maybe Text -> UserPass
UserPass Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
validateUser :: HashDBPersist site user =>
Unique user
-> Text
-> HandlerFor site Bool
validateUser :: Unique user -> Text -> HandlerFor site Bool
validateUser Unique user
userID Text
passwd = do
Maybe (Entity user)
user <- YesodDB site (Maybe (Entity user))
-> HandlerFor site (Maybe (Entity user))
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB site (Maybe (Entity user))
-> HandlerFor site (Maybe (Entity user)))
-> YesodDB site (Maybe (Entity user))
-> HandlerFor site (Maybe (Entity user))
forall a b. (a -> b) -> a -> b
$ Unique user -> YesodDB site (Maybe (Entity user))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique user
userID
Bool -> HandlerFor site Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> HandlerFor site Bool) -> Bool -> HandlerFor site Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (user -> Text -> Maybe Bool) -> Text -> user -> Maybe Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip user -> Text -> Maybe Bool
forall u. HashDBUser u => u -> Text -> Maybe Bool
validatePass Text
passwd (user -> Maybe Bool)
-> (Entity user -> user) -> Entity user -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity user -> user
forall record. Entity record -> record
entityVal (Entity user -> Maybe Bool) -> Maybe (Entity user) -> Maybe Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Entity user)
user
login :: AuthRoute
login :: AuthRoute
login = Text -> Texts -> AuthRoute
PluginR Text
"hashdb" [Text
"login"]
postLoginR :: HashDBPersist site user =>
(Text -> Maybe (Unique user))
-> AuthHandler site TypedContent
postLoginR :: (Text -> Maybe (Unique user)) -> AuthHandler site TypedContent
postLoginR Text -> Maybe (Unique user)
uniq = do
Maybe ByteString
ct <- CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"Content-Type"
let jsonContent :: Maybe Bool
jsonContent = ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"application/json") (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
simpleContentType) (ByteString -> Bool) -> Maybe ByteString -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
ct
UserPass Maybe Text
mu Maybe Text
mp <-
case Maybe Bool
jsonContent of
Just Bool
True -> m UserPass
forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireInsecureJsonBody
Maybe Bool
_ -> HandlerFor (HandlerSite m) UserPass -> m UserPass
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) UserPass -> m UserPass)
-> HandlerFor (HandlerSite m) UserPass -> m UserPass
forall a b. (a -> b) -> a -> b
$ FormInput (HandlerFor site) UserPass -> HandlerFor site UserPass
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput (HandlerFor site) UserPass -> HandlerFor site UserPass)
-> FormInput (HandlerFor site) UserPass -> HandlerFor site UserPass
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Maybe Text -> UserPass
UserPass
(Maybe Text -> Maybe Text -> UserPass)
-> FormInput (HandlerFor site) (Maybe Text)
-> FormInput (HandlerFor site) (Maybe Text -> UserPass)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field (HandlerFor site) Text
-> Text -> FormInput (HandlerFor site) (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field (HandlerFor site) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"username"
FormInput (HandlerFor site) (Maybe Text -> UserPass)
-> FormInput (HandlerFor site) (Maybe Text)
-> FormInput (HandlerFor site) UserPass
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field (HandlerFor site) Text
-> Text -> FormInput (HandlerFor site) (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field (HandlerFor site) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
Bool
isValid <- HandlerFor (HandlerSite m) Bool -> m Bool
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) Bool -> m Bool)
-> HandlerFor (HandlerSite m) Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ HandlerFor site Bool
-> Maybe (HandlerFor site Bool) -> HandlerFor site Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> HandlerFor site Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
(Unique user -> Text -> HandlerFor site Bool
forall site user.
HashDBPersist site user =>
Unique user -> Text -> HandlerFor site Bool
validateUser (Unique user -> Text -> HandlerFor site Bool)
-> Maybe (Unique user) -> Maybe (Text -> HandlerFor site Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe (Unique user)
uniq (Text -> Maybe (Unique user)) -> Maybe Text -> Maybe (Unique user)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
mu) Maybe (Text -> HandlerFor site Bool)
-> Maybe Text -> Maybe (HandlerFor site Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
mp)
if Bool
isValid
then HandlerFor (HandlerSite m) TypedContent -> m TypedContent
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) TypedContent -> m TypedContent)
-> HandlerFor (HandlerSite m) TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Creds (HandlerSite (HandlerFor site))
-> HandlerFor site TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite (HandlerFor site))
-> HandlerFor site TypedContent)
-> Creds (HandlerSite (HandlerFor site))
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds site
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"hashdb" (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mu) []
else AuthRoute -> AuthMessage -> AuthHandler site TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.InvalidUsernamePass
authHashDB :: HashDBPersist site user =>
(Text -> Maybe (Unique user)) -> AuthPlugin site
authHashDB :: (Text -> Maybe (Unique user)) -> AuthPlugin site
authHashDB = (Route site -> WidgetFor site ())
-> (Text -> Maybe (Unique user)) -> AuthPlugin site
forall site user.
HashDBPersist site user =>
(Route site -> WidgetFor site ())
-> (Text -> Maybe (Unique user)) -> AuthPlugin site
authHashDBWithForm Route site -> WidgetFor site ()
forall app. Yesod app => Route app -> WidgetFor app ()
defaultForm
authHashDBWithForm :: forall site user.
HashDBPersist site user =>
(Route site -> WidgetFor site ())
-> (Text -> Maybe (Unique user))
-> AuthPlugin site
authHashDBWithForm :: (Route site -> WidgetFor site ())
-> (Text -> Maybe (Unique user)) -> AuthPlugin site
authHashDBWithForm Route site -> WidgetFor site ()
form Text -> Maybe (Unique user)
uniq =
Text
-> (Text -> Texts -> AuthHandler site TypedContent)
-> ((AuthRoute -> Route site) -> WidgetFor site ())
-> AuthPlugin site
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"hashdb" Text -> Texts -> AuthHandler site TypedContent
dispatch (((AuthRoute -> Route site) -> WidgetFor site ())
-> AuthPlugin site)
-> ((AuthRoute -> Route site) -> WidgetFor site ())
-> AuthPlugin site
forall a b. (a -> b) -> a -> b
$ \AuthRoute -> Route site
tm -> Route site -> WidgetFor site ()
form (AuthRoute -> Route site
tm AuthRoute
login)
where
dispatch :: Text -> [Text] -> AuthHandler site TypedContent
dispatch :: Text -> Texts -> AuthHandler site TypedContent
dispatch Text
"POST" [Text
"login"] = (Text -> Maybe (Unique user)) -> AuthHandler site TypedContent
forall site user.
HashDBPersist site user =>
(Text -> Maybe (Unique user)) -> AuthHandler site TypedContent
postLoginR Text -> Maybe (Unique user)
uniq m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
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
dispatch Text
_ Texts
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
defaultForm :: Yesod app => Route app -> WidgetFor app ()
defaultForm :: Route app -> WidgetFor app ()
defaultForm Route app
loginRoute = do
YesodRequest
request <- WidgetFor app YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
let mtok :: Maybe Text
mtok = YesodRequest -> Maybe Text
reqToken YesodRequest
request
((Route app -> [(Text, Text)] -> Text) -> MarkupM ())
-> WidgetFor app ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<div id="header">
<h1>Login
<div id="login">
<form method="post" action="@{loginRoute}">
$maybe tok <- mtok
<input type=hidden name=#{defaultCsrfParamName} value=#{tok}>
<table>
<tr>
<th>Username:
<td>
<input id="x" name="username" autofocus="" required>
<tr>
<th>Password:
<td>
<input type="password" name="password" required>
<tr>
<td>
<td>
<input type="submit" value="Login">
<script>
if (!("autofocus" in document.createElement("input"))) {
document.getElementById("x").focus();
}
|]
submitRouteHashDB :: YesodAuth site => AuthHandler site (Route site)
submitRouteHashDB :: AuthHandler site (Route site)
submitRouteHashDB = do
AuthRoute -> Route site
toParent <- m (AuthRoute -> Route site)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route site -> m (Route site)
forall (m :: * -> *) a. Monad m => a -> m a
return (Route site -> m (Route site)) -> Route site -> m (Route site)
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route site
toParent AuthRoute
login