102 lines
3.7 KiB
Haskell
102 lines
3.7 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 site FormMessage
|
|
, RenderMessage site PWHashMessage
|
|
, Button site ButtonSubmit
|
|
) => AForm (HandlerT site IO) HashLogin
|
|
hashForm = HashLogin
|
|
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
|
|
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
|
|
|
|
|
hashLogin :: ( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, RenderMessage site FormMessage
|
|
, RenderMessage site PWHashMessage
|
|
, Button site ButtonSubmit
|
|
) => PWHashAlgorithm -> AuthPlugin site
|
|
hashLogin pwHashAlgo = AuthPlugin{..}
|
|
where
|
|
apName = "PWHash"
|
|
apDispatch "POST" [] = do
|
|
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect LoginR
|
|
FormMissing -> redirect LoginR
|
|
FormSuccess HashLogin{..} -> do
|
|
user <- lift . 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.
|
|
lift . setCredsRedirect $ Creds apName userIdent []
|
|
other -> do
|
|
$logDebugS "PWHash" $ tshow other
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
-- apDispatch "GET" [] = do
|
|
-- authData <- lookupBasicAuth
|
|
-- pwdata <- liftIO $ Yaml.decodeFileEither fp
|
|
|
|
-- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
|
|
|
|
-- case pwdata of
|
|
-- Left err -> $logDebugS "Auth" $ tshow err
|
|
-- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
|
|
|
|
-- case (authData, pwdata) of
|
|
-- (Nothing, _) -> do
|
|
-- notAuthenticated
|
|
-- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
|
|
-- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
|
|
-- <- [ pwe | pwe@PWEntry{..} <- pwdata'
|
|
-- , let User{..} = pwUser
|
|
-- , userIdent == usr
|
|
-- , userPlugin == apName
|
|
-- ]
|
|
-- , verifyPassword pw pwHash
|
|
-- -> lift $ do
|
|
-- runDB . void $ insertUnique pwUser
|
|
-- setCredsRedirect $ Creds apName userIdent []
|
|
-- _ -> permissionDenied "Invalid auth"
|
|
apDispatch _ _ = notFound
|
|
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 = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--hash" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/hash-login-form/hash-login-form")
|
|
|