I am trying to make client bindings for the News api provided by newsapi.org using the Haskell servant library. I have created the following endpoint:
type NewsAPI = "top-headlines" :> QueryParam "country" String :> QueryParam "apiKey" String :> Get '[JSON] TopHeadlines
And attempted to call it as follows:
topheadlines :: Maybe String -> Maybe String -> ClientM TopHeadlines
api :: Proxy NewsAPI
api = Proxy
topheadlines = client api
query = topheadlines (Just "us") (Just "<api key>")
run3 :: IO ()
run3 = do
manager' <- newManager defaultManagerSettings
users <- runClientM query (mkClientEnv manager' (BaseUrl Https "newsapi.org/v2" 443 ""))
print users
I keep getting a connection error that I don't entirely understand how to reason about:
Left (ConnectionError "HttpExceptionRequest Request {\n host = \"newsapi.org/v2\"\n port = 443\n secure = True\n requestHeaders = [(\"Accept\",\"application/json;charset=utf-8,application/json\")]\n path = \"/top-headlines\"\n queryString = \"?country=us&api_key=90a38fab85c440fa88521e0789248f83\"\n method = \"GET\"\n proxy = Nothing\n rawBody = False\n redirectCount = 10\n responseTimeout = ResponseTimeoutDefault\n requestVersion = HTTP/1.1\n}\n TlsNotSupported")
Not sure why there is no connection. Another set of client bindings I have is working fine.
It is a combination of two things:
api_key should be apiKey
Rely on parseBaseUrl
burl <- parseBaseUrl "http://newsapi.org/v2"
This worked for me in the sample project I set up.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Monad.Free
import Servant.Client.Free
import qualified Network.HTTP.Client as HTTP
import qualified Servant.Client.Internal.HttpClient as I
import Network.Wai.Handler.Warp (run)
import Servant
import System.Environment (getArgs)
type NewsAPI = "top-headlines" :> QueryParam "country" String :> QueryParam "apiKey" String :> Get '[JSON] String
topheadlines :: Maybe String -> Maybe String -> Free ClientF String
topheadlines = client api
api :: Proxy NewsAPI
api = Proxy
main :: IO ()
main = do
test
test :: IO ()
test = case topheadlines (Just "us") (Just "API_KEY") of
Pure n ->
putStrLn $ "ERROR: got pure result: " ++ show n
Free (Throw err) ->
putStrLn $ "ERROR: got error right away: " ++ show err
Free (StreamingRequest _req _k) ->
putStrLn $ "ERROR: need to do streaming request"
Free (RunRequest req k) -> do
burl <- parseBaseUrl "http://newsapi.org/v2"
mgr <- HTTP.newManager HTTP.defaultManagerSettings
let req' = I.requestToClientRequest burl req
putStrLn $ "Making request: " ++ show req'
res' <- HTTP.httpLbs req' mgr
putStrLn $ "Got response: " ++ show res'
Related
I use Servant. I need to set some callback function that will be executed on every request and it will forward the request processing/handling further (to other handler, as if this callback did not exist at all). I need it to change some IORef MyGlobalState in this callback. How to do it? Some example? Sure, I can call it explicitly in all handlers' bodies but maybe there is some right/canonical way to do it...
Consider this example server:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
import Servant
import Servant.API
import Network.Wai
import Network.Wai.Handler.Warp
import Data.IORef
import qualified Data.ByteString.Char8 as C
type API = "one" :> Get '[PlainText] String :<|> "two" :> Get '[PlainText] String
api :: Proxy API
api = Proxy
server :: Server API
server = return "1\n" :<|> return "2\n"
app :: Application
app = serve api server
main = run 3000 app
The app value is a WAI Application, defined by:
type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
Conceptually, an Application accepts a Request, and invokes a callback on its Response. WAI supports the concept of Middleware which can wrap an application, allowing preprocessing of every request and post-processing of every response in the IO monad:
type Middleware = Application -> Application
So, you can write a piece of middleware to update an IORef on every received request like so:
counter :: IORef Int -> Middleware
counter cref = convert
where
convert :: Application -> Application -- AKA Middleware
convert oldapp = newapp
where
newapp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -- AKA Application
newapp req respond = do
n <- atomicModifyIORef cref (\n' -> (n'+1,n'+1))
putStrLn $ "Request #" ++ show n ++ ": " ++ showRequest req
oldapp req respond
showRequest req = C.unpack (requestMethod req) ++ " " ++ C.unpack (rawPathInfo req)
I've broken this up into separate functions to make it clear how the middleware is constructed piece by piece, but the definition of counter can be simplified to the equivalent:
counter :: IORef Int -> Middleware
counter cref oldapp req respond
= do n <- atomicModifyIORef cref (\n' -> (n'+1,n'+1))
putStrLn $ "Request #" ++ show n ++ ": " ++ showRequest req
oldapp req respond
where
showRequest req = C.unpack (requestMethod req) ++ " " ++ C.unpack (rawPathInfo req)
Now, all you need to do is wrap your app with the middleware in main:
main = do
cref <- newIORef (0 :: Int)
run 3000 $ counter cref app
Full code:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
import Servant
import Servant.API
import Network.Wai
import Network.Wai.Handler.Warp
import Data.IORef
import qualified Data.ByteString.Char8 as C
type API = "one" :> Get '[PlainText] String :<|> "two" :> Get '[PlainText] String
api :: Proxy API
api = Proxy
server :: Server API
server = return "1\n" :<|> return "2\n"
app :: Application
app = serve api server
counter :: IORef Int -> Middleware
counter cref oldapp req respond
= do n <- atomicModifyIORef cref (\n' -> (n'+1,n'+1))
putStrLn $ "Request #" ++ show n ++ ": " ++ showRequest req
oldapp req respond
where
showRequest req = C.unpack (requestMethod req) ++ " " ++ C.unpack (rawPathInfo req)
main = do
cref <- newIORef (0 :: Int)
run 3000 $ counter cref app
Full minimal example project available here: https://github.com/chrissound/217
I've read through https://docs.servant.dev/en/v0.16/cookbook/using-free-client/UsingFreeClient.html
Where I end up with:
type API = "square"
:> Capture "n" Int
:> ReqBody '[JSON] ClientInfo
:> Get '[JSON] Int
api :: Proxy API
api = Proxy
myapitest = I.client api
getSquare :: Int -> ClientInfo -> Free ClientF Int
getSquare = Servant.Client.Free.client api
test :: IO ()
test = case getSquare 12 (ClientInfo "" "" 123 []) of
Pure n ->
putStrLn $ "ERROR: got pure result: " ++ show n
Free (Throw err) ->
putStrLn $ "ERROR: got error right away: " ++ show err
Free (RunRequest req k) -> do
burl <- parseBaseUrl "http://localhost:8000"
mgr <- HTTP.newManager HTTP.defaultManagerSettings
let req' = I.requestToClientRequest burl req
putStrLn $ "Making request: " ++ show req'
However this approach seems to just output the below:
Making request: Request {
host = "localhost"
port = 8000
secure = False
requestHeaders = [("Accept","application/json;charset=utf-8,application/json"),("Content-Type","application/json;charset=utf-8")]
path = "/square/12"
queryString = ""
method = "GET"
proxy = Nothing
rawBody = False
redirectCount = 10
responseTimeout = ResponseTimeoutDefault
requestVersion = HTTP/1.1
}
While I'm expecting a body to have some text present. The reason I expect this - because if send a request to a server and debug/inspect that - I do see a body with text present. So my question here is, why is servant saying the rawBody is False, and how do I actually get it to show the body?
The non debug code which actually sends the HTTP request is:
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
run
test
queries = myapitest 10 (ClientInfo "" "" 123 [])
run :: IO ()
run = do
manager' <- newManager defaultManagerSettings
res <- runClientM queries (mkClientEnv manager' (BaseUrl Http "localhost" 8000 ""))
case res of
Right (message) -> do
pPrint message
Left err -> do
putStrLn $ "Error: "
pPrint err
The answer is that it's hard and most solutions are not usable for applications handling many requests. You need to read the entire body into something like an MVar which you can then use. You can do this through a Middleware. However, since you consume the entire body you will need to put it back into the stream if it's suppose to be used by another middleware etc.
This is still an open issue on the servant repository:
https://github.com/haskell-servant/servant/issues/1120
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 writing an API server using Servant. The server includes persistent state. I would like to use QuickCheck to write tests for the server.
The implementation of various endpoints that make up the Servant Application require a database value. Unsurprisingly, creation of the database value is in the IO monad.
I don't understand how to combine the pieces from Hspec, Wai, QuickCheck, and Servant in a way that satisfies them all.
I see that I can perform an IO as part of creating the Hspec Spec itself and I see that I can specify that an IO be performed before each item in the Hspec Spec. Neither of these capabilities seems helpful in this case. The IO needs to be performed for each QuickCheck iteration of the property. Without this, the database accumulates state from each iteration which invalidates the definition of the property (or at least makes it greatly more complicated).
Below is my attempt to create a minimal, self-contained example of this scenario.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Data.IORef
import Test.QuickCheck
import Test.QuickCheck.Monadic
import qualified Test.Hspec.Wai.QuickCheck as QuickWai
import Test.Hspec
import Test.Hspec.Wai
import Text.Printf
import Servant
import Servant.API
import Data.Aeson
import Data.Text.Encoding
import Data.ByteString.UTF8
( fromString
)
data Backend = Backend (IORef Integer)
openBackend :: Integer -> IO Backend
openBackend n = Backend <$> newIORef n
data Acknowledgement = Ok Integer
instance ToJSON Acknowledgement where
toJSON (Ok n) = object [ "value" .= n ]
serveSomeNumber :: Backend -> Integer -> IO Acknowledgement
serveSomeNumber (Backend a) b = do
a' <- readIORef a
modifyIORef a (\n -> n + 1)
return $ Ok (a' + b)
type TheAPI = Capture "SomeNumber" Integer :> Post '[JSON] Acknowledgement
theServer :: Backend -> Server TheAPI
theServer backend = liftIO . serveSomeNumber backend
theAPI :: Proxy TheAPI
theAPI = Proxy
app :: Backend -> Application
app backend = serve theAPI (theServer backend)
post' n =
let
url = printf "/%d" (n :: Integer)
encoded = fromString url
in
post encoded ""
spec_g :: Backend -> Spec
spec_g (Backend expectedResult) =
describe "foo" $
it "bar" $ property $ \genN -> monadicIO $ do
n <- run genN
m <- run $ readIORef expectedResult
post' n `shouldRespondWith` ResponseMatcher { matchStatus = fromInteger (n + m) }
main :: IO ()
main = do
spec_g' <- spec_g `fmap` openBackend 16
hspec spec_g'
This doesn't type check:
/home/exarkun/Scratch/QuickCheckIOApplication/test/Spec.hs:119:3: error:
* Couldn't match type `WaiSession' with `PropertyM IO'
Expected type: PropertyM IO ()
Actual type: WaiExpectation
* In a stmt of a 'do' block:
post' n
`shouldRespondWith`
ResponseMatcher {matchStatus = fromInteger (n + m)}
In the second argument of `($)', namely
`do n <- run genN
m <- run $ readIORef expectedResult
post' n
`shouldRespondWith`
ResponseMatcher {matchStatus = fromInteger (n + m)}'
In the expression:
monadicIO
$ do n <- run genN
m <- run $ readIORef expectedResult
post' n
`shouldRespondWith`
ResponseMatcher {matchStatus = fromInteger (n + m)}
|
119 | post' n `shouldRespondWith` ResponseMatcher { matchStatus = fromInteger (n + m) }
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
I don't know if there is a way to fit a WaiExpectation into a PropertyM IO () at all. I don't even know if monadicIO is helpful here at all.
How can I fit these pieces together?
Define spec_g :: Background -> Spec, then take advantage of IO's Functor and Monad instances.
main = do
spec <- fmap spec_g (openBackend 16) -- fmap spec_g :: IO Background -> IO Spec
hspec spec
or more concisely,
main = spec_g <$> openBackend 16 >>= hspec
IIRC, you're supposed to run each spec or property with the with function. Here's a few properties I wrote some time ago:
with app $ describe "/reservations/" $ do
it "responds with 404 when no reservation exists" $ WQC.property $ \rid ->
get ("/reservations/" <> toASCIIBytes rid) `shouldRespondWith` 404
it "responds with 200 after reservation is added" $ WQC.property $ \
(ValidReservation r) -> do
_ <- postJSON "/reservations" $ encode r
let actual = get $ "/reservations/" <> toASCIIBytes (reservationId r)
actual `shouldRespondWith` 200
The app value serves the service, and as far as I recall, it runs the IO action for each test. I did it with an in-memory database using an IORef, and that seems to be working just fine:
app :: IO Application
app = do
ref <- newIORef Map.empty
return $
serve api $
hoistServer api (Handler . runInFakeDBAndIn2019 ref) $
server 150 []
The WQC.property function is from a qualified import:
import qualified Test.Hspec.Wai.QuickCheck as WQC
I wasn't too happy, however, with the way I had to structure my tests and properties with HSpec, so I ultimately rewrote all the tests to be driven by HUnit. I've an upcoming blog post that describes this, but I haven't published it yet.
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