95 lines
3.5 KiB
Haskell
95 lines
3.5 KiB
Haskell
module Auth.PWHash
|
|
( apHash
|
|
, hashLogin
|
|
, PWHashMessage(..)
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
|
|
import Utils.Metrics
|
|
import Utils.Form
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Yesod.Auth.Util.PasswordStore (verifyPasswordWith)
|
|
|
|
import qualified Yesod.Auth.Message as Msg
|
|
|
|
|
|
data HashLogin = HashLogin
|
|
{ hashIdent :: CI Text
|
|
, hashPassword :: Text
|
|
} deriving (Generic, Typeable)
|
|
|
|
data PWHashMessage = MsgPWHashIdent
|
|
| MsgPWHashIdentPlaceholder
|
|
| MsgPWHashPassword
|
|
| MsgPWHashPasswordPlaceholder
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
hashForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
|
, RenderMessage (HandlerSite m) PWHashMessage
|
|
, MonadHandler m
|
|
) => WForm m (FormResult HashLogin)
|
|
hashForm = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
aFormToWForm $ HashLogin
|
|
<$> areq ciField (fslpI MsgPWHashIdent (mr MsgPWHashIdentPlaceholder) & addAttr "autocomplete" "username") Nothing
|
|
<*> areq passwordField (fslpI MsgPWHashPassword (mr MsgPWHashPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
|
|
|
|
apHash :: Text
|
|
apHash = "PWHash"
|
|
|
|
hashLogin :: forall site.
|
|
( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, PersistRecordBackend User (YesodPersistBackend site)
|
|
, RenderMessage site PWHashMessage
|
|
, RenderAFormSite site
|
|
, RenderMessage site (ValueRequired site)
|
|
, Button site ButtonSubmit
|
|
) => PWHashAlgorithm -> AuthPlugin site
|
|
hashLogin pwHashAlgo = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = apHash
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderWForm FormLogin hashForm
|
|
tp <- getRouteToParent
|
|
|
|
resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
|
|
user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
|
|
case user of
|
|
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
|
|
| verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic.
|
|
observeLoginOutcome apName LoginSuccessful
|
|
setCredsRedirect $ Creds apName userIdent []
|
|
other -> do
|
|
$logDebugS apName $ tshow other
|
|
observeLoginOutcome apName LoginInvalidCredentials
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
|
|
maybe (redirect $ tp LoginR) return resp
|
|
apDispatch _ [] = badMethod
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormLogin hashForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR apName []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--hash" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/hash-login-form/hash-login-form")
|
|
|