I am making some http calls using wreq and would like to catch any exception and return an Either type. I tried something like this but could not figure out how to manipulate the calls so it will type check.
-- exhaustive pattern match omitted here
safeGetUrl :: URL -> Maybe Login -> Maybe Password -> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BS.pack login) (BS.pack pass)
r <- getWith opts url `E.catch` handler
return $ Right r
where
handler :: HttpException -> Either String (Response LBS.ByteString)
handler (StatusCodeException s _ _) = do
return $ Left $ LBS.unpack (s ^. statusMessage)
I am pasting the type error below but I know the above code will not compile. The issue is r <- getWith opts url E.catch handler. The first part returns IO (Res... but the exception handler returns Either... I tried adding lifting the getWith.. into Either but that did not type check either.
Couldn't match type ‘Either String (Response LBS.ByteString)’
with ‘IO (Response LBS.ByteString)’
Expected type: HttpException -> IO (Response LBS.ByteString)
Actual type: HttpException
-> Either String (Response LBS.ByteString)
In the second argument of ‘catch’, namely ‘handler’
In a stmt of a 'do' block: r <- getWith opts url `catch` handler
Is there a way to catch this exception and return an IO Either type?
Since #jozefg answer, the API has changed a little bit and the answer doesn't compile anymore.
Here is an updated version that compiles:
import qualified Control.Exception as E
import Control.Lens
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
import Network.HTTP.Client
import Network.Wreq as NW
type URL = String
type Login = String
type Password = String
safeGetUrl ::
URL
-> Maybe Login
-> Maybe Password
-> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BSC.pack login) (BSC.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (HttpExceptionRequest _ (StatusCodeException r _)) =
return $ Left $ BSC.unpack (r ^. NW.responseStatus . statusMessage)
Your issue is that one side of the handle returns an unwrapped response (no Either) and the other side returns an Either-wrapped exception. You then attempt to wrap the response in an Either, which you do need to do, but it's just at the wrong place. You can fix this merely by switching where you do the wrapping
safeGetUrl :: URL -> Maybe Login -> Maybe Password -> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BS.pack login) (BS.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (StatusCodeException s _ _) = do
return $ Left $ LBS.unpack (s ^. statusMessage)
However there are some other problems with your functions, remember that unpack gives back Word8s not Char. You may want to import Data.ByteString.Char as the version of unpack defined in there should work better than LBS.unpack. Without your imports though I cannot confirm this definitively. The final (working) code for me is
import Control.Lens
import Network.Wreq
import Network.HTTP.Client
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
type URL = String
type Login = String
type Password = String
safeGetUrl :: URL
-> Maybe Login
-> Maybe Password
-> IO (Either String (Response LBS.ByteString))
safeGetUrl url (Just login) (Just pass) = do
let def = defaults
opts = def & auth ?~ basicAuth (BSC.pack login) (BSC.pack pass)
(Right <$> getWith opts url) `E.catch` handler
where
handler :: HttpException -> IO (Either String (Response LBS.ByteString))
handler (StatusCodeException s _ _) = do
return $ Left $ BSC.unpack (s ^. statusMessage)
Related
What would the proper way to store an OAuth2 jwk in haskell? The certs i am retrieving are from https://www.googleapis.com/oauth2/v3/certs and I would like to avoid calling out for certs each time i need to verify the signature on a token. The options seem to be MVar, TVar, IORef, or the state monad although i am not quite sure how i would implement the state monad for this.
The basic steps would be the following (running behind a scotty server):
Receive Token from IDP
Decode Jwt with JWk's
If the decode fails due to a bad signature then check the endpoint for new certs and modify the current variable containing the cert
I am using jose-jwt, wreq, and scotty right now and have something that works but i would like to implement the approach that i am asking about rather than my existing approach.
module Main where
import ClassyPrelude
import Web.Scotty as S
import Network.Wreq as W
import Control.Lens as CL
import qualified Data.Text.Lazy as TL
import qualified Network.URI.Encode as URI
import Network.Wai.Middleware.RequestLogger
import Jose.Jwe
import Jose.Jwa
import Jose.Jwk
import Jose.Jwt
import Jose.Jws
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.List as DL
import qualified Data.ByteString.Base64 as B64
main :: IO ()
main = scotty 8080 $ do
middleware logStdoutDev
redirectCallback
oauthCallback
oauthGen
home
home :: ScottyM ()
home = do
S.get "/:word" $ do
beam <- S.param "word"
html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
redirectCallback :: ScottyM ()
redirectCallback = do
S.get "/redirect" $ do
let v = uriSchemeBuilder
redirect $ TL.fromStrict v
oauthCallback :: ScottyM ()
oauthCallback = do
matchAny "/goauth2callback" $ do
val <- body
pars <- S.params
c <- S.param "code" `rescue` (\_ -> return "haskell")
let c1 = c <> (""::Text)
r <- liftIO $ W.post "https://oauth2.googleapis.com/token"
[ "code" := (encodeUtf8 (c))
, "client_id" := (encodeUtf8 consumerAccess)
, "client_secret" := (encodeUtf8 consumerSecret)
, "redirect_uri" := (encodeUtf8 redirectURI)
, "grant_type" := ("authorization_code"::ByteString)
, "access_type" := ("offline"::ByteString)
]
let newUser = (r ^? responseBody)
case newUser of
Just b -> do
let jwt = decodeStrict (toStrict b) :: Maybe Value
case jwt of
Just (Object v) -> do
let s = HM.lookup "id_token" v
case s of
Just (String k) -> do
isValid <- liftIO $ validateToken (encodeUtf8 k)
liftIO $ print isValid
redirect "/hello_world"
_ -> redirect "/hello_world"
_ -> redirect "/hello_world"
Nothing -> redirect "/hello_world"
oauthGen :: ScottyM ()
oauthGen = do
matchAny "/callback_gen" $ do
val <- body
redirect "/hello_world"
consumerAccess :: Text
consumerAccess = "google public key"
consumerSecret :: Text
consumerSecret = "google secret key"
oAuthScopes :: Text
oAuthScopes = "https://www.googleapis.com/auth/userinfo.profile https://www.googleapis.com/auth/userinfo.email"
redirectURI :: Text
redirectURI = "http://localhost:8080/goauth2callback"
authURI :: Text
authURI = "https://accounts.google.com/o/oauth2/auth"
tokenURI :: Text
tokenURI = "https://oauth2.googleapis.com/token"
projectId :: Text
projectId = "project name"
responseType :: Text
responseType = "code"
oAuthUriBuilder :: [(Text, Text)]
oAuthUriBuilder =
[ ("client_id", consumerAccess)
, ("redirect_uri", redirectURI)
, ("scope", oAuthScopes)
, ("response_type", responseType)
]
uriSchemeBuilder :: Text
uriSchemeBuilder = authURI <> "?" <> (foldr (\x y -> (fst x ++ "=" ++ (URI.encodeText $ snd x)) ++ "&" ++ y) "" oAuthUriBuilder)
validateToken :: ByteString -> IO (Either JwtError JwtContent)
validateToken b = do
keySet <- retrievePublicKeys
case keySet of
Left e -> return $ Left $ KeyError "No keyset supplied"
Right k -> do
let header = JwsEncoding RS256
Jose.Jwt.decode k (Just $ header) b
retrievePublicKeys :: IO (Either String [Jwk])
retrievePublicKeys = do
r <- liftIO $ W.get "https://www.googleapis.com/oauth2/v3/certs"
case (r ^? responseBody) of
Nothing -> return $ Left "No body in response from google oauth api"
Just a -> do
let v = eitherDecode a :: Either String Value
case v of
Left e -> return $ Left e
Right (Object a) -> do
let keySet = HM.lookup "keys" a
case keySet of
Just k -> do
let kS = eitherDecode (Data.Aeson.encode k) :: Either String [Jwk]
return $ kS
_ -> return $ Left "No Key set provided"
_ -> return $ Left $ "Incorrect response type from https://www.googleapis.com/oauth2/v3/certs"
The specific part i am interested in replacing is:
retrievePublicKeys :: IO (Either String [Jwk])
retrievePublicKeys = do
r <- liftIO $ W.get "https://www.googleapis.com/oauth2/v3/certs"
case (r ^? responseBody) of
Nothing -> return $ Left "No body in response from google oauth api"
Just a -> do
let v = eitherDecode a :: Either String Value
case v of
Left e -> return $ Left e
Right (Object a) -> do
let keySet = HM.lookup "keys" a
case keySet of
Just k -> do
let kS = eitherDecode (Data.Aeson.encode k) :: Either String [Jwk]
return $ kS
_ -> return $ Left "No Key set provided"
_ -> return $ Left $ "Incorrect response type from https://www.googleapis.com/oauth2/v3/certs"
I've though about storing the Jwk's in redis but i would think that there is a better approach available.
The expected result is to be able to safely modify the cert that i am obtaining from google and using it on subsequent decodings without the need to constantly hit the endpoint.
(Note: Yes i know that it is bad practice to roll your own security but this is just out of interest)
If you go by something like three layers (ReaderT design pattern), then caching an IORef or TVar in the environment part in a ReaderT YourEnv IO would be the way to go. (atomicModifyIORef' should be sufficient.)
The Holmusk link will recommend the jwt package, but having just added, in another language at work, in-memory caching of Google's OAuth2 certificates, picking a JWT library in Haskell also appears very much like a feature trade-off:
For example, jwt explicitly states that it doesn't check the exp expiration timestamp, but as far as I can see, jose-jwt doesn't even address the exp expiration timestamp that it decodes. google-oauth2-jwt does, and embeds the endpoint (for good and for bad, harder to mock), but doesn't provide a lot of ergonomics beyond that. (Edit: It appears that jose does handle expiration, and that it's also the most popular of those I mentioned on Hackage.)
I am working on OAuth2 authentication for a Yesod application and I am having a type error that I really really don't understand. The code is broken at the moment, and I have a few :: IO ()'s and undefineds thrown around to help me isolate the type error, but the relevant code is:
getAccessToken :: Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
getAccessToken manager oa code = do
let (uri, defaultBody) = accessTokenUrl oa code
let body = defaultBody <> [ ("client_id", TE.encodeUtf8 . oauthClientId $ oa )
, ("client_secret", TE.encodeUtf8 . oauthClientSecret $ oa)
, ("resource", TE.encodeUtf8 . oauthClientId $ oa)
]
response <- performOAuth2PostRequest manager oa uri body
return undefined
performOAuth2PostRequest :: Manager -> OAuth2 -> URI -> PostBody -> IO (Response ByteString)
performOAuth2PostRequest manager oa uri body = do
defaultReq <- uriToRequest uri
let addBasicAuth = applyBasicAuth (TE.encodeUtf8 . oauthClientId $ oa)
(TE.encodeUtf8 . oauthClientSecret $ oa)
let req = (addBasicAuth . updateRequestHeaders Nothing) defaultReq
(httpLbs (urlEncodedBody body req) manager) :: IO (Response ByteString)
Notice that I am specifically setting the type of the httpLbs (urlEnc...) manager action as an IO (Response ByteString) using the ScopedTypeVariables extension. Also, that line of code should be an IO action because it's being performed at the top level of an IO action.
In fact, I ran a GHCi session and did:
Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.Internal
Network.HTTP.Conduit Data.Functor Prelude> :t httpLbs
httpLbs
:: Control.Monad.IO.Class.MonadIO m =>
Request
-> Manager -> m (Response Data.ByteString.Lazy.Internal.ByteString)
Which confirms my understanding that httpLbs should yield a MonadIO m => m (Response ByteString).
But here is the error I get:
• Couldn't match type ‘Response
Data.ByteString.Lazy.Internal.ByteString’
with ‘IO (Response ByteString)’
Expected type: Manager -> IO (Response ByteString)
Actual type: Manager
-> Response Data.ByteString.Lazy.Internal.ByteString
• The function ‘httpLbs’ is applied to two arguments,
its type is ‘Request
-> m1 (Response Data.ByteString.Lazy.Internal.ByteString)’,
it is specialized to ‘Request
-> Manager -> Response Data.ByteString.Lazy.Internal.ByteString’
Why is GHC specializing m to Response instead of IO? How do I fix it?
You haven't included your import statements, making it difficult to debug this. My best guess though is that you've imported Network.HTTP.Simple, which provides functions that do not require an explicit Manager argument. I'm guessing this from the error message providing the expected type:
Request -> m1 (Response Data.ByteString.Lazy.Internal.ByteString)
Solution: either change the import, or drop the Manager argument.
I'm trying to find a way to check if a webpage exists in Haskell. The server is HTTP2 / HTTPS only and I'm trying to check if the page exists in a servant application.
Is there any Haskell packages with good documentation to just check if the status code is 200 or 404? And working with strong HTTPS and HTTP2 servers?
Here what I currently have with http-conduit but I'm receiving weird exceptions (TlsExceptionHostPort (HandshakeFailed (Error_Protocol ("expecting server hello, got alert : [(AlertLevel_Fatal,HandshakeFailure)]",True,HandshakeFailure))) "thibaud.dauce.fr" 443 and StatusCodeException).
... other imports
import qualified Network.HTTP.Conduit as HTTP
... other types
type AppM = ReaderT Config (EitherT ServantErr IO)
newComment :: String -> OneComment -> AppM Int64
newComment baseUrl oneComment = do
time <- liftIO getCurrentTime
response <- HTTP.withManager $ \manager -> do
request <- HTTP.parseUrl $ url oneComment
HTTP.httpLbs request manager
case (statusIsSuccessful $ HTTP.responseStatus response, startswith baseUrl (url oneComment)) of
(_, False) -> return 0
(True, True) -> do
theNewComment <- runDb $ insert $ Comment (url oneComment) (content oneComment) time
return $ fromSqlKey theNewComment
_ -> return 0
Some examples using wreq
{-# LANGUAGE OverloadedStrings #-}
import Network.Wreq
import Control.Lens
import Control.Exception as E
import Network.HTTP.Client (HttpException)
test1 = do
r <- get "https://httpbin.org/get"
print $ r ^. responseStatus . statusCode
-- throws an exception
test2 = do
r <- get "https://www.google123123.com"
print $ r ^. responseStatus . statusCode
testUrl url = do
r <- get url
return $ r ^. responseStatus . statusCode
-- catching the exception
test3 = do
st <- testUrl "https://www.google123123123.com" `E.catch` handler
print st
where
handler :: HttpException -> IO Int
handler _ = return 999
I am trying to test broken links but, when I use Wreq's get method and run into a 404, I get an exception (see bottom) rather than a statusCode to handle. Only 200s seem to be returned.
I tried to follow the error-handling code in the tutorial but I can't find a way to return the same type as get u. Moreover, this seems to be more complexity than I need in this instance.
How can I simply prevent the exception and just return the responseStatus as is
verifySeatme :: Maybe URL -> IO UrlStatus
verifySeatme url = do
case url of
Nothing -> return None
Just "" -> return None
Just u -> do
seatmeResp <- get u --`E.catch` handler
-- r ^? responseBody . key "url"
-- could also check for redirect to errorPage.aspx
if seatmeResp ^. W.responseStatus . statusCode == 200
then return (Working u)
else return Broken
where
handler e#(StatusCodeException s respHeaders _) =
do
return respHeaders
Here is the exception thrown, and you can see it has the stateCode i want
*Main> re <- get "https://www.seatme.nl/restaurant/1371/Londen.htm"
*** Exception: StatusCodeException (Status {statusCode = 404, statusMessage = "Not Found"}) [("Cache-Control","private"),....
Yuras suggested using options, but I have been unable to work from the example using params to one using checkStatus :: Lens' Options (Maybe StatusChecker):
getData :: IO Restos
getData = do
let opts = defaults & customStatusHandler
jdata <- asJSON =<< getWith opts "http://localhost/restos-short.json" :: IO Resp
let
restos = jdata ^. W.responseBody
verified <- mapM processEntry restos
return verified
-- type StatusChecker = Status -> ResponseHeaders -> CookieJar -> Maybe SomeException
customStatusHandler :: W.StatusChecker
customStatusHandler st res _ =
Just res
NOTE: the answer is outdated, see other answers.
I never used Wreq, but it looks like you should use getWith to pass custom options and checkStatus to configure status handling.
An example:
getWith (set checkStatus (Just $ \_ _ _ -> Nothing) defaults)
"http://google.com/hello/world"
The \_ _ _ -> Nothing is a function to check status code, see StatusChecker. It returns nothing indicating that any status code is OK.
To expand on the answer by Evelyn Schneider, I got this to work with
r <- getWith opts url
where
opts = set Network.Wreq.checkResponse (Just $ \_ _ -> return ()) defaults
For posterity: newer versions of wreq (starting with 0.5) have replaced checkStatus with checkResponse, which takes different arguments. An equivalent to Yuras' answer would now be:
getWith opts url
where opts = set checkResponse (\_ _ -> return ()) defaults
Here's the checkStatus function I ended up with after researching a bit. I couldn't figure out how to convert a HttpException to a SomeException, but then I found Control.Monad.Catch.SomeException. This will ignore 404s and re-throw all other exceptions.
import Network.HTTP.Client.Types
import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
import qualified Control.Exception as E
import Control.Monad.Catch (SomeException(..))
notFoundMeansNothing :: Status -> ResponseHeaders -> CookieJar -> Maybe E.SomeException
notFoundMeansNothing s h c
| s == status404 = Nothing
| otherwise =
if statusIsClientError s || statusIsServerError s then
Just . SomeException $ StatusCodeException s h c
else
Nothing
There is a method:
import Control.Applicative ((<$>))
import Network.HTTP.Types
getJSON :: String -> IO (Either String Value)
getJSON url = eitherDecode <$> simpleHttp url
And instead of this:
method1 :: String -> IO Object
method1 url = do
maybeJson <- getJSON url
case maybeJson of
jsonValue ->
case jsonValue of
Object jsonObject -> return jsonObject
_ -> error "error123"
Left errorMsg -> error $ "error456"
I can do this:
method1 :: String -> IO Object
method1 url = do
Right jsonValue <- getJSON url
case jsonValue of
Object jsonObject -> return jsonObject
_ -> error "error123"
Is there any way to simplify it even more without using any libraries like lens?
If you don't care about the particular error messages, you could merge the patterns further:
method1 url = do
Right (Object jsonObject) <- getJSON url
return jsonObject