servant
servant copied to clipboard
haskell-servant
UVerb HasServer Instance
Been trying to debug this all day but I think it's not working because maybe there's an interface missing for servant-auth with UVerbs. Maybe that's not supported yet?
The error I'm getting is as follows.
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:112:55: error:
• No instance for (HasServer
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(UVerb
'PUT
'[JSON]
'[WithStatus 201 NoContent, WithStatus 204 NoContent])))
'[JWTSettings, CookieSettings,
BasicAuthData -> IO (AuthResult AuthenticatedUser)])
arising from a use of ‘serveWithContext’
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
112 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Not sure what I'm missing here, so would be infinitely grateful for any input.
type LocallyStoredItemAPI (sectionName :: Symbol) listType detailType patchType patchResponseType = sectionName :>
( Get '[JSON] listType -- LIST
:<|> Capture "id" ItemID :> Get '[JSON] detailType -- GET
:<|> Capture "id" ItemID :> ReqBody '[JSON] detailType :> UVerb 'PUT '[JSON] '[WithStatus 201 NoContent, WithStatus 204 NoContent] -- PUT
:<|> Capture "id" ItemID :> ReqBody '[JSON] patchType :> Patch '[JSON] patchResponseType -- PATCH
:<|> ReqBody '[JSON] detailType :> PostCreated '[JSON] NoContent -- POST
:<|> Capture "id" ItemID :> Delete '[JSON] NoContent -- DELETE
)
putLocallyStoredItem :: (SetModifiedTime i, ToJSON i)
=> Config
-> (LocallyStoredItemId -> C.RelativePath)
-> LocallyStoredItemId
-> i
-> Handler (Union '[WithStatus 201 NoContent, WithStatus 204 NoContent])
putLocallyStoredItem cfg dsJsonFileFromId dsid body = do
itemExistsBefore <- liftIO $ (C.fileExistsF cfg) (dsJsonFileFromId dsid)
-- Write to disk with modified time
liftIO $ withCurrentModifiedTime body >>= writeDsFile . encode
if itemExistsBefore then
Servant.Server.UVerb.respond (WithStatus @204 NoContent)
else
Servant.Server.UVerb.respond (WithStatus @201 NoContent)
where writeDsFile = C.writeFileF cfg (dsJsonFileFromId dsid)
I realise this isn't a very minimal example. If I can I'll work on one but on a deadline ATM. Hope you understand. I'm following the examples from servant Cookbook. Looked everywhere for an import to add the interfaces but think writing them myself may be beyond my understanding of Servant ATM.
Am rewriting to try and use HasStatus and return custom types without UVerb to see if that works
It looks like this AddSetCookie type family is not defined for UVerb, which could be the root cause of your problem. I'll look into it.
I am not seeing the Auth combinator being used in your example though.
Realised can't rewrite with HasStatus cos StatusOf is a type level.
@gdeest I think the Auth combinator is being used here, unless I'm getting my terminology mixed up.
type API = EventsAPI :<|> RulesAPI :<|> AlertGroupsAPI :<|> DataSourcesAPI :<|> JoinsAPI :<|> UserAPI :<|> PasswordGeneratorAPI :<|> SparkAPI :<|> AlertTypesAPI
type APIServer = Auth '[SA.Cookie, SA.JWT, SA.BasicAuth] AuthenticatedUser :> API
This is the rest of the server setup section
server :: APIConfig.Config -> Server APIServer
server cfg (Authenticated user) = (eventsServer cfg user)
:<|> (rulesServer cfg user)
:<|> (alertGroupsServer cfg user)
:<|> (dataSourcesServer cfg user)
:<|> (joinsServer cfg user)
:<|> (usersServer cfg user)
:<|> (passwordGeneratorServer cfg user)
:<|> (sparkServer)
:<|> (alertTypesServer cfg user)
server _ SAS.BadPassword = throwAll err401
server _ SAS.NoSuchUser = throwAll err401
server _ SAS.Indefinite = throwAll $ SAS.wwwAuthenticatedErr "invvar-api"
api :: Proxy APIServer
api = Proxy
mkApp :: APIConfig.Config -> IO Application
mkApp config = do
myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config --- This is where authCheck function is injected
cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
where jwtSecretPath = APIConfig.jwtSecretPath $ APIConfig.cliConfig config
runApi :: APIConfig.Config -> IO ()
runApi config = do
let settings =
setPort port $
setLogger (logServantRequest log') $
setBeforeMainLoop (logString log' LogLevel.Info ("listening on port " ++ show port)) $
setOnException (logServantException log')
defaultSettings
APIConfig.createRequiredDirectories config
withProducerThread log' (APIConfig.kafkaBroker $ APIConfig.cliConfig config) producerQ $ do
runSettings settings =<< mkApp config
where port = APIConfig.port $ APIConfig.cliConfig config
log' = APIConfig.globalLog config
producerQ = APIConfig.kafkaQueue config
Again, sorry for the less than minimal example. I'm up against a deadline or I'd put something more appropriate together before posting.
Linking back to this thread (UVerb Support?) from the old separate servant-auth repo's Issues list, in case it helps anyone progress.
Okay, I've gotten a minimal example to compile. Instead of pulling the current package versions from Stackage, I set my extra-deps field in my stack.yaml to the following to get the very latest version from this repository:
- git: https://github.com/haskell-servant/servant.git
commit: af3dde1b1da84889876094c31a131eb9dcc3da9f
subdirs:
- servant
- servant-server
- servant-client
- servant-client-core
- servant-auth/servant-auth
- servant-auth/servant-auth-server
- servant-auth/servant-auth-client
I think the required work has already been done, but a release hasn't been cut y et. So we've just been looking at Hackage/Stackage and not realizing it?
Will post minimal example soon.
Ok, I'll try updating servant as per the version from @and-pete above and see if I can still reproduce.
@and-pete I am not sure how it could work, given that servant-auth-server currently doesn't mention UVerb ? :thinking:
@robwithhair Could you try against #1571 as well ? I think it should solve your issue, but I didn't test it yet.
@and-pete from not enough interfaces to too many! I'm now getting the following and I have tried compiling with IncoherentInstances too but no change from below error. Running gdeest's pull request now.
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:94:55: error:
• Overlapping instances for HasServer
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
(UVerb
'PUT
'[JSON]
'[WithStatus 201 NoContent, WithStatus 204 NoContent])))
'[JWTSettings, CookieSettings,
BasicAuthData -> IO (AuthResult AuthenticatedUser)]
arising from a use of ‘serveWithContext’
Matching instances:
instance [overlappable] forall k (api :: k) (context :: [*]).
(TypeError ...) =>
HasServer api context
-- Defined in ‘Servant.Server.Internal’
...plus 32 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
(The choice depends on the instantiation of ‘’
To pick the first instance above, use IncoherentInstances
when compiling the other instance declarations)
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
94 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
|
@gdeest I'm getting the following...
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:94:55: error:
• Duplicate element in list:
'[StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 201 NoContent)),
StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 204 NoContent))]
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
94 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Completed 242 action(s).
Maybe this is to do with WithStatus deriving Eq and ignoring the status code which is at the type level? Just a guess.
Well, at least, there is some progress :)
It is probably just a matter of implementing HasStatus a => HasStatus (Headers ls a). There is clearly no duplicate element here, it is probably a misfire of the custom type error due to GHC's failure to apply the StatusOf type family (custom type errors are hard to get right).
Here you go both Rob (@robwithhair) and Gaël (@gdeest)!
https://gist.github.com/and-pete/7ff284a02a82dc4801aa2f38dd15f5e1
I've included the full stack.yaml that I'm using to import everything.
For reference, my package.yaml file (...and thus my .cabal file) has no other language extensions listed. The pragmas that you see listed at the start of the Main.hs file is everything there is.
No extra instances were needed to be written. But if your WithStatus is returning something polymorphic (e.g. it could be Text or String), you can't just get away with:
respond $ WithStatus @401 "Hello World"
You need to annotate it with either
respond $ WithStatus @401 ("Hello World"::Text)
-- or
respond $ WithStatus @401 @Text "Hello World"
That caught me out for a while earlier when trying to debug your issue.
I also saw the "duplicate" error you've pasted somewhere along the way as well. But hopefully you can work backwards from what I've included in the Gist and avoid it from now :)
Peter
@and-pete It seems UVerb is only used in the unprotected login route in your example ; is that correct ? the API under Auth does not seem to use UVerb, so I don't think the situation is similar.
@gdeest
Ahh that's correct. Whoops! I'll give the instance you've pushed a shot shortly and protect a UVerb route with the Auth combinator.
@gdeest building from 9030ea442cd4acaef74e8d5c9a6aa70f392a8d89 gives me the following
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:94:55: error:
• Duplicate element in list:
'[StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 201 NoContent)),
StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 204 NoContent))]
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
94 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
My bad, I implemented the instance for the wrong type :) (Header instead of `Headers). It should be fixed.
@gdeest similar error again clean build of 6bf95544050eb0333e6b115b048274be032a05b8
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:94:55: error:
• Duplicate element in list:
'[StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 201 NoContent)),
StatusOf
(Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 204 NoContent))]
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
94 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
That is quite strange - the StatusOf family should definitely evaluate now. I'll investigate a bit more.
EDIT: My change wasn't pushed properly… @robwithair you may try again :crossed_fingers:
@gdeest new error now as follows when clean building 0dd77adec87d25940f40e5342af09ea88ea819f2
/home/robwithhair/GGMR/vfde-inv-var-api/src/API.hs:94:55: error:
• Couldn't match type ‘sop-core-0.5.0.2:Data.SOP.NS.NS
sop-core-0.5.0.2:Data.SOP.BasicFunctors.I
'[Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 201 NoContent),
Headers
'[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
(WithStatus 204 NoContent)]’
with ‘Headers '[Header "Set-Cookie" SetCookie] cookied1’
arising from a use of ‘serveWithContext’
• In the second argument of ‘($)’, namely
‘serveWithContext api cfg (server config)’
In a stmt of a 'do' block:
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
In the expression:
do myKey <- fromSecret <$> ByteString.readFile jwtSecretPath
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck config
....
pure . ifRequest shouldApplyApiGateway apiGateway
$ serveWithContext api cfg (server config)
|
94 | pure . ifRequest shouldApplyApiGateway apiGateway $ serveWithContext api cfg (server config)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@gdeest so NS I is a Union type Union = NS I so is it that we need an instance for Union something?
Had a good try but couldn't figure this one out. I'm going to re-write to remove UVerb for now. I will keep my code in a branch so I can quickly re-test. If I can in the future I'll try and produce minimal example from the project. Let me know if any pull requests need a re-test.
Yes, I actually need to implement the AddHeader typeclass, which may be a bit tricky. I'll investigate further and ping you if anything comes up.
@robwithhair The PR should now work for your case (it comes with a working test).
@gdeest Thanks for that :) I think there might still be an issue.
I've updated my Gist to demonstrate.
(edit: for reference, am going off haskell-servant/servant commit 2d085ec2591cb0fd4c61dfaae3d84cab25837c0c)
You can see the discrepancy if you attempt to access (without credentials):
- An
Auth-combinator protected route that does have aUVerbin its response type - An
Auth-combinator protected route that does not have aUverbin its response type
Basically, for 1. you get back the expected 401 but also an XSRF-TOKEN cookie, even though your request itself had no credentials.
And with 2. you get back the expected 401 as well as no XSRF-TOKEN cookie. I believe this is the expected behaviour.
Neither endpoint is wrapped with extra headers, beyond what should be provided by the 'Auth' combinator. :)
@gdeest I will retest ASAP. My test suite should fail if it doesn't authenticate properly.
@and-pete The problem is likely that throwing a 401 servant error is fundamentally different than returning a 401 response (without any error being explicitly raised). throwError short circuits the code path, but respond (WithStatus @401 …) doesn't, and cookies get added anyhow.
I don't have any clear solution to this problem in mind yet.
@and-pete The problem is likely that throwing a 401 servant error is fundamentally different than returning a 401 response (without any error being explicitly raised).
throwErrorshort circuits the code path, butrespond (WithStatus @401 …)doesn't, and cookies get added anyhow.
Ahh interesting! That does seem to be it. Replacing the throwError err401 line with pure dummyUser leads to the protected non-UVerb route returning an XSRF-TOKEN just like the protected UVerb route does. Is that just the blank errHeaders field in err401 overwriting the Servant.Auth.* ones?
Thanks for all of your help and speedy responses so far btw :)
I don't have a clear solution in mind either 😅 😅
It does seem a pretty deliberate choice in the following piece of code in Servant.Auth.Server.Internal
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
makeCookies authResult = do
xsrf <- makeXsrfCookie cookieSettings
fmap (Just xsrf `SetCookieCons`) $
case authResult of
(Authenticated v) -> do
ejwt <- makeSessionCookie cookieSettings jwtSettings v
case ejwt of
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
_ -> return $ Nothing `SetCookieCons` SetCookieNil
...that the author is choosing to map that...
fmap (Just xsrf `SetCookieCons`)
...function over all outcomes (both Authenticated and otherwise). I'll have to go back and read the issues/commits in the archived servant-auth repo in case I'm missing a reason why.
Can we think of any situations where the expected behaviour of this library would be to return just the XSRF token by itself?
At the moment, I believe the existing code above is equivalent to:
...
case authResult of
(Authenticated v) -> do
ejwt <- makeSessionCookie cookieSettings jwtSettings v
case ejwt of
Nothing -> return $ Just xsrf `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
Just jwt -> return $ Just xsrf `SetCookieCons` (Just jwt `SetCookieCons` SetCookieNil)
_ -> return $ (Just xsrf)`SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
But if there's no time that you'd ever want the XSRF token returned alone in absence of the JWT session cookie, then I believe the following might be okay:
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
makeCookies = \case
Authenticated v -> do
ejwt <- makeSessionCookie cookieSettings jwtSettings v
case ejwt of
Nothing ->
return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil) -- Removed `Just xsrf` as first element here
Just jwt -> do
xsrf <- makeXsrfCookie cookieSettings -- only making the xsrf token in the one case it's needed
return $ Just xsrf `SetCookieCons` (Just jwt `SetCookieCons` SetCookieNil)
_otherResult ->
return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil) -- Removed `Just xsrf` as first element here
Probably a worse idea is controlling it in the way that cookie list is serialized via mkHeaders from the bottom of Servant.Auth.Server.Internal.AddSetCookie:
mkHeaders :: SetCookieList x -> [HTTP.Header]
mkHeaders x = ("Set-Cookie",) <$> mkCookies x
where
mkCookies :: forall y. SetCookieList y -> [BS.ByteString]
mkCookies SetCookieNil = []
mkCookies (SetCookieCons Nothing rest) = mkCookies rest
mkCookies (SetCookieCons (Just y) rest)
= toByteString (renderSetCookie y) : mkCookies rest
Handling the XSRF token issue via one of the above is, of course, separate to what you pointed out about throwError/throwAll err401 being treated differently than WithStatus @401.
Anyway thanks again :) And sorry for the long comment! I'm taking time away from my dayjob at the moment and have the opportunity to get stuck in more than normal.
Interesting ! I'll give it more thought tomorrow and give it a spin, but at first glance, it does make sense to me to craft the headers in makeCookies entirely based on the result of authentication rather than implicitly relying on the underlying ExceptT transformer in the Handler monad to prevent the addition of an extraneous cookie, as the current implementation does.
We probably want to test this mechanism a bit more thoroughly in the PR.