85 lines
3.0 KiB
Haskell
85 lines
3.0 KiB
Haskell
module Auth.PWHash
|
|
( hashLogin
|
|
, PWHashMessage(..)
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
|
|
import Utils.Form
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
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
|
|
| MsgPWHashPassword
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
hashForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) PWHashMessage
|
|
, MonadHandler m
|
|
) => AForm m HashLogin
|
|
hashForm = HashLogin
|
|
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
|
|
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
|
|
|
|
|
hashLogin :: forall site.
|
|
( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, PersistRecordBackend User (YesodPersistBackend site)
|
|
, RenderMessage site PWHashMessage
|
|
, RenderMessage site AFormMessage
|
|
, Button site ButtonSubmit
|
|
) => PWHashAlgorithm -> AuthPlugin site
|
|
hashLogin pwHashAlgo = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = "PWHash"
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch "POST" [] = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm
|
|
tp <- getRouteToParent
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect $ tp LoginR
|
|
FormMissing -> redirect $ tp LoginR
|
|
FormSuccess HashLogin{..} -> 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) -> -- (2^) is magic.
|
|
setCredsRedirect $ Creds apName userIdent []
|
|
other -> do
|
|
$logDebugS "PWHash" $ tshow other
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR "PWHash" []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--hash" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/hash-login-form/hash-login-form")
|
|
|