Could not deduce constraint

CouldNotDeduce.hs

{-# 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 "hardcoded" ["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" dispatch loginWidget
  where
    dispatch "POST" ["login"] = postLoginR >>= sendResponse
    dispatch _ _ = notFound
    loginWidget toMaster = do
      request <- getRequest
      [whamlet|
        $newline never
        <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 "hardcoded" 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

Error.txt

[ 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
   |                                ^^^^^^^^^^...