This question already has an answer here:
What's wrong with this YesodAuth instance?
(1 answer)
Closed 4 years ago.
I'm trying to add
instance YesodAuthEmail App
to the Yesod-Postgres scaffolding (yesod version 1.6) and getting stuck on a compile error.
The relevant code is:
instance YesodAuth App where
type AuthId App = UserId
....
authPlugins :: App -> [AuthPlugin App]
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
where extraAuthPlugins = [ authEmail ]
instance YesodAuthEmail App where
type AuthEmailId App = UserId
afterPasswordRoute _ = HomeR
addUnverified email verkey =
runDB $ insert $ User email Nothing
The error I receive is:
/home/justin/code/yesodemail/src/Foundation.hs:273:11: error:
• Could not deduce: m ~ HandlerFor site0 from the context: MonadAuthHandler App m
bound by the type signature for:
addUnverified :: Yesod.Auth.Email.Email -> VerKey -> AuthHandler App (AuthEmailId App)
....
Expected type: m (AuthEmailId App)
Actual type: HandlerFor site0 (Key User)
Based on the types,
getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
I would have thought this would compile. What I am misunderstanding?
P.S. I've tried to include everything relevant, but the full Foundation.hs is at https://gist.github.com/hyperpape/39d4d2baf67d3bdbdba45a943e7e0425
The type of runDB is:
runDB :: YesodDB site a -> HandlerFor site a
in order to call it in AuthHandler you need to lift it to HandlerFor.
If I am not mistaken this is what the liftHandler method from MonadHandler is for.
If you compose your runDB call with it, it should work:
addUnverified email verkey =
liftHandler . runDB $ insert $ User email Nothing
I found a detailed answer to your question here.
Related
I am using Obelisk OAuth to handle multiple OAuth options (Facebook, Google, & Apple, though only FB is shown below).
I have getOAuthDetails which gets the correct details for each provider.
I use it in backend (at the bottom), but it gives me this error:
backend/src/Backend.hs:144:47-54: error:
• Couldn't match expected type ‘OAuthProvider’
with actual type ‘OAuth a1’
• In the first argument of ‘getOAuthDetails’, namely ‘provider’
In the expression: getOAuthDetails provider code
In a pattern binding: (t, reqUrl) = getOAuthDetails provider code
• Relevant bindings include
oauthRoute :: a1 (bound at backend/src/Backend.hs:140:41)
provider :: OAuth a1 (bound at backend/src/Backend.hs:140:29)
|
144 | let (t, reqUrl) = getOAuthDetails provider code
| ^^^^^^^^
This error is confusing to me because I am explicitly feeding in OAuthProvider as provider in that function. Why would it then say actual type ‘OAuth a1’?
data OAuthProvider = OAuthProvider_Facebook
| OAuthProvider_Google
| OAuthProvider_Apple
getOAuthDetails :: OAuthProvider -> T.Text -> (TokenRequest BackendRoute, String) -- NB. this last T.Text is a reqUrl
getOAuthDetails OAuthProvider_Facebook code = (fbTokenReq code, (T.unpack fbReqUrl))
getOAuthDetails OAuthProvider_Google code = (googTokenReq code, (T.unpack googReqUrl))
getOAuthDetails OAuthProvider_Apple code = (applTokenReq code, (T.unpack applReqUrl))
fbTokenReq :: T.Text -> TokenRequest BackendRoute
fbTokenReq code = TokenRequest
{ _tokenRequest_grant = TokenGrant_AuthorizationCode $ T.encodeUtf8 code
, _tokenRequest_clientId = "fake-client-id" -- Get this from the OAuth authorization server
, _tokenRequest_clientSecret = "fake-client-secret" -- Get this from the OAuth authorization server
, _tokenRequest_redirectUri = BackendRoute_OAuth
}
fbReqUrl :: T.Text
fbReqUrl = "https://graph.facebook.com/oauth/access_token"
...
-- provider2Auth :: OAuthProvider -> OAuth RedirectUriParams
-- provider2Auth
backend :: OAuthProvider -> Backend BackendRoute FrontendRoute
backend provider = Backend
{ _backend_run = \serve -> do
cfg <- getConfigs
let route = T.strip $ T.decodeUtf8 $ cfg ! "common/route"
tlsMgr <- Https.newTlsManager
serve $ \case
BackendRoute_Missing :/ () -> error "404"
BackendRoute_OAuth :/ provider :/ oauthRoute -> case oauthRoute of
OAuth_RedirectUri :/ redirectParams -> case redirectParams of
Nothing -> liftIO $ error "Expected to receive the authorization code here"
Just (RedirectUriParams code _mstate) -> do
let (t, reqUrl) = getOAuthDetails provider code
rsp <- liftIO $ flip Http.httpLbs tlsMgr =<< getOauthToken reqUrl route checkedEncoder t
-- ^ this response should include the access token and probably a refresh token
liftIO $ print rsp
, _backend_routeEncoder = fullRouteEncoder
}
EDIT:
ob run displayed this:
backend/src/Backend.hs:140:9-43: error:
• Could not deduce: a1 ~ R OAuth
from the context: a ~ Data.Dependent.Sum.DSum OAuth Identity
bound by a pattern with constructor:
BackendRoute_OAuth :: BackendRoute (R OAuth),
in a case alternative
at backend/src/Backend.hs:139:7-24
‘a1’ is a rigid type variable bound by
a pattern with pattern synonym:
:/ :: forall (f :: * -> *). () => forall a. f a -> a -> R f,
in a case alternative
at backend/src/Backend.hs:139:7-36
• In the pattern: OAuth_RedirectUri :/ redirectParams
In a case alternative:
OAuth_RedirectUri :/ redirectParams
-> case redirectParams of
Nothing
-> liftIO $ error "Expected to receive the authorization code here"
Just (RedirectUriParams code _mstate)
-> do let ...
....
In the expression:
case oauthRoute of {
OAuth_RedirectUri :/ redirectParams
-> case redirectParams of
Nothing
-> liftIO $ error "Expected to receive the authorization code here"
Just (RedirectUriParams code _mstate) -> do ... }
• Relevant bindings include
oauthRoute :: a1 (bound at backend/src/Backend.hs:139:41)
provider :: OAuth a1 (bound at backend/src/Backend.hs:139:29)
|
140 | OAuth_RedirectUri :/ redirectParams -> case redirectParams of
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
backend/src/Backend.hs:143:47-54: error:
• Couldn't match expected type ‘OAuthProvider’
with actual type ‘OAuth a1’
• In the first argument of ‘getOAuthDetails’, namely ‘provider’
In the expression: getOAuthDetails provider code
In a pattern binding: (t, reqUrl) = getOAuthDetails provider code
• Relevant bindings include
oauthRoute :: a1 (bound at backend/src/Backend.hs:139:41)
provider :: OAuth a1 (bound at backend/src/Backend.hs:139:29)
|
143 | let (t, reqUrl) = getOAuthDetails provider code
| ^^^^^^^^
Thanks to Srid, I saw that I had two providers. I modified my backend to:
backend :: OAuthProvider -> Backend BackendRoute FrontendRoute
backend provider = Backend
{ _backend_run = \serve -> do
cfg <- getConfigs
let route = T.strip $ T.decodeUtf8 $ cfg ! "common/route"
tlsMgr <- Https.newTlsManager
serve $ \case
BackendRoute_Missing :/ () -> error "404"
BackendRoute_OAuth :/ oauthRoute -> case oauthRoute of
OAuth_RedirectUri :/ redirectParams -> case redirectParams of
Nothing -> liftIO $ error "Expected to receive the authorization code here"
Just (RedirectUriParams code _mstate) -> do
let (t, reqUrl) = getOAuthDetails provider code
rsp <- liftIO $ flip Http.httpLbs tlsMgr =<< getOauthToken reqUrl route checkedEncoder t
-- ^ this response should include the access token and probably a refresh token
liftIO $ print rsp
, _backend_routeEncoder = fullRouteEncoder
}
And now I get:
Running test...
<interactive>:623:116-130: error:
• Couldn't match expected type ‘Backend
backendRoute0 FrontendRoute’
with actual type ‘OAuthProvider
-> Backend BackendRoute FrontendRoute’
• Probable cause: ‘backend’ is applied to too few arguments
In the third argument of ‘Obelisk.Run.run’, namely ‘backend’
In the expression:
Obelisk.Run.run
55245
(Obelisk.Run.runServeAsset
"/Users/levelchart/Documents/git/app-obelisk/static")
backend
Frontend.frontend
In an equation for ‘it’:
it
= Obelisk.Run.run
55245
(Obelisk.Run.runServeAsset
"/Users/levelchart/Documents/git/app-obelisk/static")
backend
Frontend.frontend
I can not figure out what types should go in my Foundation.hs when implementing type classes from the authentication plugin / it's use of the auth subsite:
I can feel that I am very close, but I lack understanding. I am simply trying to use a different layout for the login/registration pages.
In Foundation.hs:
instance YesodAuthSimple App where
type AuthSimpleId App = UserId
...
-- Works
onRegisterSuccess :: YesodAuthSimple site => AuthHandler site Html
onRegisterSuccess = authLayout $ [whamlet|
$newline never
<div>
<h1>You Registered successfully.
<p>
Some text here.
|]
-- Works when I do not write a type signature
loginTemplate toParent mErr = $(widgetFile "authpartials/login")
-- Does not work with or without type signatures
customAuthLayout widget = do
master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
mcurrentRoute <- getCurrentRoute
pc <- widgetToPageContent $ do
$(widgetFile "custom-auth-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
The 432:15 is referring to the widgetToPageContent call.
In the type class definition Simple.hs:
class (YesodAuth site, PathPiece (AuthSimpleId site)) => YesodAuthSimple site where
type AuthSimpleId site
...
customAuthLayout :: WidgetFor site () -> AuthHandler site Html
...
I pasted in the definition of customAuthLayout from defaultLayout from Foundation.hs
Here is the error I get from GHC:
Foundation.hs:432:15: error:
• Could not deduce: m ~ HandlerFor App
from the context: MonadAuthHandler App m
bound by the type signature for:
customAuthLayout :: WidgetFor App () -> AuthHandler App Html
at src/Foundation.hs:(427,5)-(434,79)
‘m’ is a rigid type variable bound by
the type signature for:
customAuthLayout :: WidgetFor App () -> AuthHandler App Html
at src/Foundation.hs:(427,5)-(434,79)
Expected type: m (PageContent (Route App))
Actual type: HandlerFor App (PageContent (Route App))
• In a stmt of a 'do' block:
pc <- widgetToPageContent
$ do (do do (asWidgetT GHC.Base.. toWidget)
((blaze-markup-0.8.2.2:Text.Blaze.Internal.preEscapedText
GHC.Base.. Data.Text.pack)
"<!-- custom-auth-layout -->
<body class="d-flex align-items-center bg-auth border-top border-top-2 border-primary">")
....)
In the expression:
do master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
mcurrentRoute <- getCurrentRoute
....
In an equation for ‘customAuthLayout’:
customAuthLayout widget
= do master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
....
|
432 | pc <- widgetToPageContent $ do
| ^^^^^^^^^^^^^^^^^^^^^^^^...
I have used this tutorial successfully for normal (non-subsite pages) https://ersocon.net/cookbooks/yesod/html-and-seo/custom-layouts
But I am getting tripped up by the subsite types. I have read Michael Snoyman's very good old blog post on subsite types but I cannot understand GHC's error message.
I suspect either the type signature in Simple.hs is wrong, or I am missing something from the function definition.
Try to add liftHandler before widgetToPageContent:
...
pc <- liftHandler $ widgetToPageContent $ do
$(widgetFile "custom-auth-layout")
...
Key lines in the error message are:
Could not deduce: m ~ HandlerFor App
...
Expected type: m (PageContent (Route App))
Actual type: HandlerFor App (PageContent (Route App))
It is basically telling us that it expected a more generic type m, but instead it got a HandlerFor App. So the solution is simply to lift the call to widgetToPageContent using the liftHandler function.
To elaborate further, if we look at the type signature of the function widgetToPageContent, we see that it returns HandlerFor site (PageContent (Route site)). In this case, site instantiates to App, and that is the HandlerFor App (PageContent (Route App)) you see in the error message.
Similarly, your customLayout function returns AuthHandler site Html. AuthHandler is just a type synonym that constrains site to a type equivalent to HandlerSite m which is also an instance of YesodAuth. This also resolves to App, and that is why we get MonadAuthHandler App m and m (PageContent (Route App)) in the error message.
This question already has an answer here:
What's wrong with this YesodAuth instance?
(1 answer)
Closed 4 years ago.
I'm trying to add
instance YesodAuthEmail App
to the Yesod-Postgres scaffolding (yesod version 1.6) and getting stuck on a compile error.
The relevant code is:
instance YesodAuth App where
type AuthId App = UserId
....
authPlugins :: App -> [AuthPlugin App]
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
where extraAuthPlugins = [ authEmail ]
instance YesodAuthEmail App where
type AuthEmailId App = UserId
afterPasswordRoute _ = HomeR
addUnverified email verkey =
runDB $ insert $ User email Nothing
The error I receive is:
/home/justin/code/yesodemail/src/Foundation.hs:273:11: error:
• Could not deduce: m ~ HandlerFor site0 from the context: MonadAuthHandler App m
bound by the type signature for:
addUnverified :: Yesod.Auth.Email.Email -> VerKey -> AuthHandler App (AuthEmailId App)
....
Expected type: m (AuthEmailId App)
Actual type: HandlerFor site0 (Key User)
Based on the types,
getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
I would have thought this would compile. What I am misunderstanding?
P.S. I've tried to include everything relevant, but the full Foundation.hs is at https://gist.github.com/hyperpape/39d4d2baf67d3bdbdba45a943e7e0425
The type of runDB is:
runDB :: YesodDB site a -> HandlerFor site a
in order to call it in AuthHandler you need to lift it to HandlerFor.
If I am not mistaken this is what the liftHandler method from MonadHandler is for.
If you compose your runDB call with it, it should work:
addUnverified email verkey =
liftHandler . runDB $ insert $ User email Nothing
I found a detailed answer to your question here.
While toying around with persistent, I can't figure out where does the PersistStoreWrite (BaseBackend b) constraint come from. I can't see it on the signature of insert.
x :: (
MonadIO m,
PersistStoreRead b,
PersistStoreWrite b,
PersistStoreWrite (BaseBackend b) -- <--- where does this come from?
) => ReaderT b m ()
x = do
now <- liftIO getCurrentTime
aTaskId <- insert (TaskItem "Hello" now)
aTask <- get aTaskId
liftIO (print aTask)
The above works fine, but if I remove the mentioned constraint, the compiler complains ("arising from a use of insert").
I'm using stack with lts-7.12 resolver (GHC 8, persistent 2.6).
Data definition for the record:
share [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migrateAll"] [persistLowerCase|
TaskItem
name Text
submittedAt UTCTime
deriving Show
The strange thing was, also the get method required the BaseBackend write. As hinted by #snoyman, this is partly due to the generated TH code. Part of the TH-generated splice:
instance PersistStore backend =>
PersistEntity (TaskItemGeneric backend) where
type PersistEntityBackend (TaskItemGeneric backend) = backend
Note that PersistStore is an alias to PersistStoreWrite. This, in combination with the constraint PersistRecordBackend record backend on the get method of PersistStoreRead, which expands to:
type PersistRecordBackend record backend =
(PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
indeed results in the inferred constraint PersistStoreWrite (BaseBackend backend).
Solution
In fact this is trivial - a sensible BaseBackend should always support writes. So I just added aliases for the constraints:
type PersistRead b = (PersistStoreRead b, PersistStoreWrite (BaseBackend b))
type PersistWrite b = (PersistRead b, PersistStoreWrite b)
so
x :: (MonadIO m, PersistWrite b) => ReaderT b m ()
x = do
now <- liftIO getCurrentTime
aTaskId <- insert (TaskItem "Hello" now)
aTask <- get aTaskId
liftIO (print aTask)
I am working on a Servant 0.7.1 application and trying to use Persistent-2.5 to query a Postgresql database, but I am getting mismatched types with a Persistent query.
This application was previously working with Servant 0.4 and Persistent 2.2, but when I went to Servant 0.7.1 in order to try out the BasicAuth stuff (different stack resolver, which is why I ended up with a higher version of Persistent too), I changed from EitherT ServantErr IO to Servant's Handler monad, and for some reason I could no longer get the Persistent query to compile.
Here's my model definition:
share [mkPersist sqlSettings] [persistLowerCase|
ESeries json
label String
name String Maybe
relatedId ESeriesId Maybe
|]
Based on this blog-post, I have a runDb function that looks like this, which will run inside a ReaderT:
runDb query = do
pool <- asks getPool
liftIO $ runSqlPool query pool
Finally, I have the following api definition and handler:
type ESeriesApi = "series" :> Get '[JSON] [ESeries]
eSeriesApi :: Proxy ESeriesApi
eSeriesApi = Proxy
type AppM = ReaderT Config Handler
readerToHandler :: Config -> AppM :~> Handler
readerToHandler cfg = Nat $ \x -> runReaderT x cfg
eServer :: Config -> Server ESeriesApi
eServer cfg = enter (readerToHandler cfg) eSeriesServer
app :: Config -> Application
app cfg = serve eSeriesApi (eServer cfg)
eSeriesServer :: ServerT ESeriesApi AppM
eSeriesServer = allSeries
allSeries :: AppM [ESeries]
allSeries = do
series <- runDb $ selectList [] []
let results = map (\(Entity _ e) -> e) series
liftIO $ sequence results
I have tried many different variations on this, but it always comes down to the same error:
• Couldn't match type ‘persistent-2.5:Database.Persist.Class.PersistEntity.PersistEntityBackend
(IO ESeries)’
with ‘Database.Persist.Sql.Types.Internal.SqlBackend’
arising from a use of ‘selectList’
• In the second argument of ‘($)’, namely ‘selectList [] []’
In a stmt of a 'do' block: series <- runDb $ selectList [] []
In the expression:
do { series <- runDb $ selectList [] [];
let results = map (\ (Entity _ e) -> ...) series;
liftIO $ sequence results }
It seems that selectList is not returning the right type?
Edit:
I should have mentioned that I am trying to do this with Persistent 2.5 and this code previously worked with earlier versions of Persistent.
It looks like runSqlPool is expecting SqlPersistT or ReaderT SqlBackend but selectList is returning PersistEntityBackend (IO ESeries)