Created
October 22, 2018 13:51
-
-
Save geraldus/da50b29c7c4d93a66e485167ecc9e8eb to your computer and use it in GitHub Desktop.
Could not deduce constraint
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE QuasiQuotes #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE RankNTypes #-} | |
module Local.Auth.Plugin | |
( PrizmAuthPlugin(..) | |
, authPrizm | |
, loginR ) where | |
import Import.NoFoundation | |
import Yesod.Auth (AuthPlugin (..), AuthRoute, | |
Creds (..), Route (..), YesodAuth, | |
loginErrorMessageI, setCredsRedirect, | |
AuthHandler) | |
import qualified Yesod.Auth.Message as Msg | |
import Yesod.Core | |
import Yesod.Form (ireq, runInputPost, textField) | |
import Control.Applicative ((<$>), (<*>)) | |
import Data.Text (Text) | |
loginR :: AuthRoute | |
loginR = PluginR "prizm auth plugin" ["login"] | |
class (YesodAuth site) => PrizmAuthPlugin site | |
{- | |
-- | Check whether given user name exists among hardcoded names. | |
doesUserNameExist :: Text -> AuthHandler site Bool | |
-- | Validate given user name with given password. | |
validatePassword :: Text -> Text -> AuthHandler site Bool | |
-} | |
authPrizm :: PrizmAuthPlugin m => AuthPlugin m | |
authPrizm = | |
AuthPlugin "prizm auth plugin" dispatch loginWidget | |
where | |
dispatch "POST" ["login"] = postLoginR >>= sendResponse | |
dispatch _ _ = notFound | |
loginWidget toMaster = do | |
request <- getRequest | |
[whamlet| | |
$newline never | |
<h1>PRIZM-Обменник | Вход | |
<form method="post" action="@{toMaster loginR}"> | |
$maybe t <- reqToken request | |
<input type=hidden name=#{defaultCsrfParamName} value=#{t}> | |
<table> | |
<tr> | |
<th>_{Msg.UserName} | |
<td> | |
<input type="text" name="username" required> | |
<tr> | |
<th>_{Msg.Password} | |
<td> | |
<input type="password" name="password" required> | |
<tr> | |
<td colspan="2"> | |
<button type="submit" .btn .btn-success>_{Msg.LoginTitle} | |
|] | |
postLoginR :: (PrizmAuthPlugin site) | |
=> AuthHandler site TypedContent | |
postLoginR = do | |
(username, password) <- runInputPost | |
((,) Control.Applicative.<$> ireq textField "username" | |
Control.Applicative.<*> ireq textField "password") | |
authRes <- checkCreds username password | |
if authRes == AuthSuccess | |
then setCredsRedirect (Creds "prizm auth plugin" username []) | |
else loginErrorMessageI LoginR | |
(if authRes == InvalidAuthPair | |
then Msg.InvalidUsernamePass | |
else Msg.IdentifierNotFound username) | |
checkCreds :: Text -> Text -> AuthHandler site AuthResult' | |
checkCreds username password = runDB $ do | |
mayUser <- getBy $ UniqueUser username | |
return $ case mayUser of | |
Nothing -> NoSuchUser | |
Just user -> if (userPassword (entityVal user) == Just password) | |
then AuthSuccess | |
else InvalidAuthPair | |
data AuthResult' | |
= AuthSuccess | |
| NoSuchUser | |
| InvalidAuthPair | |
deriving Eq |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Building library for prizm-exchange-0.0.0.. | |
[ 9 of 19] Compiling Local.Auth.Plugin ( src/Local/Auth/Plugin.hs, .stack-work/dist/x86_64-linux/Cabal-2.2.0.1/build/Local/Auth/Plugin.o ) | |
/home/gman/Lab/Haskell/prizm-exchange/src/Local/Auth/Plugin.hs:86:32: error: | |
• Could not deduce: m ~ HandlerFor site0 | |
from the context: MonadAuthHandler site m | |
bound by the type signature for: | |
checkCreds :: Text -> Text -> AuthHandler site AuthResult' | |
at src/Local/Auth/Plugin.hs:(86,1)-(92,32) | |
‘m’ is a rigid type variable bound by | |
the type signature for: | |
checkCreds :: Text -> Text -> AuthHandler site AuthResult' | |
at src/Local/Auth/Plugin.hs:(86,1)-(92,32) | |
Expected type: m AuthResult' | |
Actual type: HandlerFor site0 AuthResult' | |
• In the expression: | |
runDB | |
$ do mayUser <- getBy $ UniqueUser username | |
return | |
$ case mayUser of | |
Nothing -> NoSuchUser | |
Just user | |
-> if (userPassword (entityVal user) == Just password) then | |
AuthSuccess | |
else | |
InvalidAuthPair | |
In an equation for ‘checkCreds’: | |
checkCreds username password | |
= runDB | |
$ do mayUser <- getBy $ UniqueUser username | |
return | |
$ case mayUser of | |
Nothing -> NoSuchUser | |
Just user -> ... | |
| | |
86 | checkCreds username password = runDB $ do | |
| ^^^^^^^^^^... |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment