Servant Server Sent Events support - haskell

How do I define a Server-Sent Event(SSE) end point for servant. The docs don't seem to cover this case.
If Servant is not designed for the realtime use case, which Haskell server framework supports SSE?

servant uses WAI, and you can always dip down into normal WAI applications and all the libraries that exist for it with the Raw combinator. So you can use Network.Wai.EventSource from wai-extra to create an Application, which is the type of handlers for Raw endpoints. Something like:
type MyApi = "normalapi" :> NormalApi
:<|> "sse" :> Raw
myServer :: Server MyAPI
myServer = normalServer :<|> eventSourceAppChan myChan

Thanks to the answer of user2141650 I managed to get a working example of a server-sent events that uses channels.
The gist of the solution is as follows. Assume that we have an echo server that just echoes messages:
newtype Message = Message { msgText :: Text }
Then we'll define three end-points, one for creating sessions, one for sending messages to a session, and the other for retrieving the messages of a session using server-sent events:
# Create a new session
curl -v -XPOST http://localhost:8081/session/new
# And subscribe to its events
curl -v http://localhost:8081/events/0
# And from another terminal
curl -v -XPOST http://localhost:8081/session/0/echo\
-H "Content-Type: application/json" -d '{"msgText": "Hello"}'
Now let's see how to implement the end-point to write a message for a given session, into a channel:
sendH :: SessionId -> Message -> Handler NoContent
sendH sid msg = do
-- lookupChannel :: Env -> SessionId -> IO (Maybe (Chan ServerEvent))
mCh <- liftIO $ lookupChannel env sid
case mCh of
Nothing ->
throwError err404
Just ch -> do
liftIO $ writeChan ch (asServerEvent msg)
return NoContent
The function to convert a Message to a ServerEvent is shown below:
import Data.Text.Encoding as TE
import qualified Data.Text.Lazy as T
asServerEvent :: Message -> ServerEvent
asServerEvent msg = ServerEvent
{ eventName = Just eName
, eventId = Nothing
, eventData = [msg']
}
where
eName :: Builder
eName = fromByteString "Message arrived"
msg' :: Builder
msg' = fromByteString $ TE.encodeUtf8 $ T.toStrict $ msgText msg
Finally, the handler for retrieving the messages from the server can be implemented using evetSourceAppChan, as follows:
eventsH sid = Tagged $ \req respond -> do
mCh <- lookupChannel env sid
case mCh of
Nothing -> do
let msg = "Could not find session with id: "
<> TLE.encodeUtf8 (T.pack (show sid))
respond $ responseLBS status404 [] msg
Just ch -> do
ch' <- dupChan ch
eventSourceAppChan ch req respond
The full solution is available at my sanbox.
I hope that helps.

Yeah, I'm not sure about server sent events in servant, but more comprehensive Web frameworks like Yesod has support for that.
Take a look at the package yesod-eventsource
Yesod has pretty nice cookbook so you can event find there pretty nice example

Servant can handle this well with just a bit of boilerplate. In this case you need a new content type (EventStream) and a supporting class to render types into SSE format.
{-# LANGUAGE NoImplicitPrelude #-}
module Spencer.Web.Rest.ServerSentEvents where
import RIO
import qualified RIO.ByteString.Lazy as BL
import Servant
import qualified Network.HTTP.Media as M
-- imitate the Servant JSON and OctetStream implementations
data EventStream deriving Typeable
instance Accept EventStream where
contentType _ = "text" M.// "event-stream"
instance ToSSE a => MimeRender EventStream a where
mimeRender _ = toSSE
-- imitate the ToJSON type class
class ToSSE a where
toSSE :: a -> BL.ByteString
-- my custom type with simple SSE render
data Hello = Hello
instance ToSSE Hello where
toSSE _ = "data: hello!\n\n"
-- my simple SSE server
type MyApi = "sse" :> StreamGet NoFraming EventStream (SourceIO Hello)
myServer :: Server MyAPI
myServer = source [Hello, Hello, Hello]
Browser result:
data: hello!
data: hello!
data: hello!

Related

Making client bindings in Haskell servant - ConnectionError

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'

perform IO inside wai application

I am following the basic dispatching section of wai application.
I am able to catch the url parameter. How can I perform IO operation using these params.
I would like to use runCommand of System.Process to execute a system command using these parameters.
:t runCommand give
runCommand :: String -> IO ProcessHandle
my Main.hs
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad
import Network.Wai
import Network.HTTP.Types
import Network.Wai.Handler.Warp (run)
import Data.ByteString
import Control.Monad
import System.Process
import qualified Data.ByteString.Lazy.Char8 as L8
main :: IO ()
main = do
run 8080 app
app :: Application
app request respond = respond $ case rawPathInfo request of
"/" -> indexHtml
"/wake" -> wakeMeUP request
_ -> fourNotFour
indexHtml :: Response
indexHtml = responseFile
status200
[("Content-Type","text/html")]
"index.html"
Nothing
wakeMeUP :: Request -> Response
wakeMeUP request =
let query = queryString request
hour = join $ lookup "hour" query
min = join $ lookup "min" query
--I would like to use runCommand "using hour and min variables"
in responseLBS
status200
[("Content-Type","text/plain")]
"Alarm set at...to be coded later"
fourNotFour :: Response
fourNotFour = responseLBS
status404
[("Content-Type","text/plain")]
"404 not found"
Your design prevents it, because of how you have written app,
app request respond = respond $ case rawPathInfo request of
which says that you immediately respond. Note the type of Application:
type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
Since the result type has an IO, you have the opportunity to do I/O before yielding a value. So you could:
app request respond = do
whateverResult <- runCommand "whatever"
respond $ ...
(You could also do it afterward, at least according to the types:
app request respond = do
rcvd <- respond $ ...
runCommand "whatever"
return rcvd
Though that's a bit odd to do for the continuation-passing idiom being used here (the (a -> b) -> b pattern in the Application type). It means that the command will be run after everything else, for some definition of "everything else" that we can't know without reading the wai source.)
Anyway, you probably don't want the command to be run inside app, but rather in wakeMeUp, which means you need to change some types around. In particular,
wakeMeUp :: Request -> IO Response
-- ^^
and suitably monadify the function. Then your app needs to not call respond immediately, so you can say
app request respond =
response <- case rawPathInfo request of
"/" -> return indexHtml
-- ^^^^^^
"/wake" -> wakeMeUp request
-- no change, because wakeMeUp now has an IO return type
...
respond response
If this is gibberish to you, it's time to do some monad tutorials. Or if you just want to get the damn thing working, I recommend Dan Piponi's The IO Monad For People who Simply Don't Care. Happy hacking!

Catch-all or default routing

These days it's not uncommon to need to return a file (say, index.html) from the backend if the requested route doesn't match an existing API endpoint or another static asset. This is especially handy when using react-router and browserHistory.
I'm a bit stumped as to how I might approach this with Servant. I did wonder if intercepting 404's might be the way to go, but then of course sometimes the API will need to legitimately issue 404. Here's the kind of thing I've been using to experiment:
data Wombat = Wombat
{ id :: Int
, name :: String
} deriving (Eq, Show, Generic)
instance ToJSON Wombat
wombatStore :: [Wombat]
wombatStore =
[ Wombat 0 "Gertrude"
, Wombat 1 "Horace"
, Wombat 2 "Maisie"
, Wombat 3 "Julius"
]
wombats :: Handler [Wombat]
wombats = return wombatStore
wombat :: Int -> Handler Wombat
wombat wid = do
case find (\w -> Main.id w == wid) wombatStore of
Just x -> return x
Nothing -> throwE err404
type API =
"api" :> "wombats" :> Get '[JSON] [Wombat] :<|>
"api" :> "wombats" :> Capture "id" Int :> Get '[JSON] Wombat :<|>
Raw
api :: Proxy API
api = Proxy
server :: Server API
server = wombats
:<|> wombat
:<|> serveDirectory "static"
app :: Application
app = serve api server
main :: IO ()
main = run 3000 app
I'd love to see an example of how I could go about adding a 'default route' that sends an HTML response if the request doesn't match an API endpoint or anything in the static directory. Toy repo here.
You got it, basically. serveDirectory "static" can be replaced by any wai Application, so for instance, we could have:
...
{-# LANGUAGE OverloadedStrings #-}
...
import Network.Wai (responseLBS)
import Network.HTTP.Types (status200)
...
server :: Server API
server = wombats
:<|> wombat
:<|> hello
hello :: Application
hello req respond = respond $
responseLBS
status200 --
[("Content-Type", "text/plain")] -- headers
"Hello, World!" -- content
...
To a first approximation, wai applications are simply Request -> Response, but the docs tell a fuller story:
Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
So since you've got access to IO, you can check if the file exists and if so serve it, otherwise do whatever you like. In fact, wai defines type Middleware = Application -> Application, so you might think up a handy Middleware that wraps up hello (or any other Application!) in a file existence-checker-and-server.
Here is another route:
serveDirectory is defined as
serveDirectory = staticApp . defaultFileServerSettings . addTrailingPathSeparator
defaultFileServerSettings contains a field ssLookupFile which you can change to serve what you want if the file was not found. Perhaps:
import WaiAppStatic.Types
import WaiAppStatic.Storage.Filesystem
import Network.Wai.Application.Static
import System.FilePath
fileOrIndex root pieces = do
res <- ssLookupFile (defaultFileServerSettings root) pieces
case res of
LRNotFound -> undefined -- index.html here
_ -> return res
serveStatic root =
let root' = addTrailingPathSeparator root in
staticApp $ (defaultFileServerSettings root') {ssLookupFile = fileOrIndex root'}

IO monad issues when trying to implement WAI HTTP Server + Fallback Proxy

What I'm trying to do is to create a somewhat smart reverse proxy server that should process some requests on its own and forward the others to the backend of choice. To make it challenging I'm trying hard to do it in Haskell, which I am a total newbie in.
Here's the code I've come up so far:
{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative
import Data.ByteString
import Network.HTTP.ReverseProxy
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import qualified Network.HTTP.Client as HC
helloApp :: Application
helloApp req respond =
respond $ responseLBS status200 [("Content-Type", "text/plain")] "Hello"
proxyStubApp :: Application
proxyStubApp req respond =
respond $ responseLBS status200 [("Content-Type", "text/plain")] "You've hit the stub"
proxyApp :: IO Application
proxyApp = do
manager <- HC.newManager HC.defaultManagerSettings
return $ waiProxyTo (const $ return $ WPRProxyDest ProxyDest { pdHost = "localhost", pdPort = 9393 }) defaultOnExc manager
app :: Application
app req respond =
serve req respond
where serve = lookupServeFunction req
lookupServeFunction :: Request -> Application
lookupServeFunction req
| isInfixOf "sample_path" (rawPathInfo req) = proxyStubApp
| otherwise = helloApp
main = run 3011 =<< (logStdoutDev <$> return app)
It works fine, but when I exchange proxyStubApp for actual proxyApp I am forced to add IO all over the place. Particularly it gets added to app, consequently leaving me with the following compilation error message:
Couldn't match expected type ‘Request -> t5 -> t4’
with actual type ‘IO Application’
The equation(s) for ‘app’ have two arguments,
but its type ‘IO Application’ has none
I feel like I understand why it is happening, but I'm out of ideas of how to cope with it :( Or am I doing something totally wrong?
Thank you!
P.S. Here are the dependencies should you want to compile the thing on your own: wai warp http-types text bytestring wai-extra time http-reverse-proxy http-client
The IO in IO Application is kind-of redundant. Note that
type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
so, expanding proxyApp's arguments (what you already do in proxyStubApp), you get
proxyApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
proxyApp req continuation = do
manager <- HC.newManager HC.defaultManagerSettings
waiProxyTo (...) req respond
That works, because in either case
proxyApp :: IO Application
proxyApp = do
manager <- HC.newManager ...
...
and
proxyApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
proxyApp req continuation = do
manager <- HC.newManager ...
...
the IO action HC.newManager ... is "run within IO".
You may find it conceptually clearer to construct an Application in IO and hand it to some other place, and I won't argue with you. I want to note though, that you choose the Application based on the Request, so in a way you are in the hypothetical HTTP monad when choosing, so lookupServeFunction's signature Request -> Application makes more sense to me.
If you want to keep that type signature for proxyApp,
lookupServeFunction and app will have to be in IO as well and main will have to change accordingly, e.g.
myApp <- app
...
As haoformayor said, It is generally easier to work without the outer IO layer.
You might also like to simplify main.
fmap logStdoutDev (return app)
is the same as
return (logStdoutDev app)
and
run 3011 =<< return (logStdoutDev app)
is the same as
run 3011 (logStdoutDev app)
You might want to install hlint, which will help you spot these.

x-oauth-basic header isn't the same in CURL and HTTP.Conduit

This is more than likely me missing some vital piece of information or something, but here goes.
Currently I'm trying to insert my own header, namely x-oauth-basic, into my HTTP request using the HTTP.Conduit library. It sorta works, but not in my intended way,
submitPostRequest urlString githubKey body =
case parseUrl urlString of
Nothing -> return $ "URL Syntax Error"
Just initReq -> withManager $ \manager -> do
let req = initReq { secure = False -- Turn on https
, method = "POST"
, requestHeaders = [("x-oauth-basic", (encodeUtf8 githubKey))]
<> [("User-Agent", "HsCMS")]
, requestBody = RequestBodyBS (toStrict body)
, checkStatus = \_ _ _ -> Nothing
}
res <- httpLbs req manager
return $ responseBody res
the important bit being
requestHeaders = [("x-oauth-basic", (encodeUtf8 githubKey))]
<> [("User-Agent", "HsCMS")]
Using a HTTP sinkhole, I can see the header is formed as HTTP_X_OAUTH_BASIC. It shouldn't have the HTTP bit in front. Testing with curl,
curl -u 78y8713k1j23nkjnkjnuy366366363666gdasddd:x-oauth-basic --request POST --data '{"description":"Updated via API","files":{"file1.txt":{"filename": "newsies.txt", "content":"New Demo"}}' http://www.posttestserver.com/post.php\?dir\=Testing
the header doesn't appear there, which suggests that the sinkhole doesn't pick up x-headers. The curl example also works with my intended endpoint which is the github API, so I know the curl approach is correct, and my HTTP.Conduit one is not.
So my question is, how do I get my HTTP.Conduit header to appear as a x-header, such as curls', instead of the current http-x-header that I'm getting?
Also, don't worry, the github key used is not an actual key...
Update and fix
So, as mentioned in a comment to Michael Snoymans' answer, it got solved by using a different header, namely ("Authorization", "token " <> (encodeUtf8 githubKey)) which apparently was somewhat what CURL was sending when doing <token>:x-oauth-basic.
I've tried to update the title to fit a little better, but am open to suggestions...
Thanks for all the help!
I think the problem is with your sinkhole application. It appears like it's printing CGI versions of the headers. I don't know what the sinkhole looks like, so I implemented a simple one in Warp, and indeed the request header is being passed through correctly. You can clone the project on FP Haskell Center to try it out yourself. For completeness, here's the code below:
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent.Async (withAsync)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Monoid (mempty, (<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (RequestBody (RequestBodyBS),
checkStatus, httpLbs, method,
parseUrl, requestBody,
requestHeaders, responseBody, secure,
withManager)
import Network.HTTP.Types (status200)
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp (run)
import System.Environment (getEnv)
main :: IO ()
main = do
port <- fmap read $ getEnv "PORT"
withAsync (run port app) $ const $ do
submitPostRequest
("http://localhost:" ++ show port)
"dummy-key"
"dummy body" >>= print
app :: Wai.Application
app req = do
liftIO $ mapM_ print $ Wai.requestHeaders req
return $ Wai.responseLBS status200 [] mempty
submitPostRequest :: String -> Text -> ByteString -> IO L.ByteString
submitPostRequest urlString githubKey body =
case parseUrl urlString of
Nothing -> return $ "URL Syntax Error"
Just initReq -> withManager $ \manager -> do
let req = initReq { secure = False -- Turn on https
, method = "POST"
, requestHeaders = [("x-oauth-basic", (encodeUtf8 githubKey))]
<> [("User-Agent", "HsCMS")]
, requestBody = RequestBodyBS body
, checkStatus = \_ _ _ -> Nothing
}
res <- httpLbs req manager
return $ responseBody res
When I run this, the output in the console is:
("Host","localhost:8004")
("Accept-Encoding","gzip")
("Content-Length","10")
("x-oauth-basic","dummy-key")
("User-Agent","HsCMS")
Empty

Resources