FP Complete

Menu

Web Services

Web Application Interface (WAI)

Example handlers

Example middleware

Building applications

Hello WAI

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types

main :: IO ()
main = run 3000 $ req send -> send $ responseBuilder
  status200
  (case lookup "marco" $ requestHeaders req of
     Nothing -> []
     Just val -> [("Polo", val)])
  "Hello WAI!"
$ curl -H Marco:foo -i http://localhost:3000
HTTP/1.1 200 OK
Transfer-Encoding: chunked
Date: Fri, 19 May 2017 11:23:15 GMT
Server: Warp/3.2.11.2
Polo: foo

Hello WAI!

Question Notice the lower case marco in the code, yet it matches. What black magic is this?

Application

type Application
   = Request
  -> (Response -> IO ResponseReceived)
  -> IO ResponseReceived

-- Basically a more complicated version of
type SimpleApp = Request -> IO Response
#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.ByteString.Lazy as BL
import System.IO

main :: IO ()
main = run 3000 $ _req send -> withBinaryFile "Main.hs" ReadMode $ h -> do
  lbs <- BL.hGetContents h -- evil lazy I/O! We'll do better soon
  send $ responseLBS
    status200
    [("Content-Type", "text/plain")]
    lbs

Exercise Write a function unsimpleApp :: SimpleApp -> Application.

Request

Lots of fields in Request, let’s do some simple routing:

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types

main :: IO ()
main = run 3000 $ req send ->
  case pathInfo req of
    [] -> send $ responseBuilder
      status303
      [("Location", "/home")]
      "Redirecting"
    ["home"] -> send $ responseBuilder
      status200
      [("Content-Type", "text/plain")]
      "This is the home route"
$ curl -i http://localhost:3000
HTTP/1.1 303 See Other
Transfer-Encoding: chunked
Date: Fri, 19 May 2017 11:31:25 GMT
Server: Warp/3.2.11.2
Location: /home

$ curl http://localhost:3000/home
This is the home route

$ curl http://localhost:3000/foo
Something went wrong

Exercise Write an application that somehow responds to query string parameters.

Response

A few core smart constructors for Response:

responseFile
  :: Status
  -> ResponseHeaders
  -> FilePath
  -> Maybe FilePart
  -> Response`

responseBuilder
  :: Status
  -> ResponseHeaders
  -> Builder
  -> Response`

-- Just a wrapper for `responseBuilder`
responseLBS
  :: Status
  -> ResponseHeaders
  -> ByteString
  -> Response

responseStream
  :: Status
  -> ResponseHeaders
  -> StreamingBody
  -> Response

type StreamingBody
   = (Builder -> IO ()) -- send a chunk
  -> IO ()              -- flush the buffer
  -> IO ()

-- Useful for WebSockets in particular
responseRaw
  :: (   IO ByteString         -- receive from client
      -> (ByteString -> IO ()) -- send to client
      -> IO ())
  -> Response
  -> Response

Let’s send a file the right way (responseFile):

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types

main :: IO ()
main = run 3000 $ _req send -> send $ responseFile
    status200
    [("Content-Type", "text/plain")]
    "Main.hs"
    Nothing

And with streaming

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.ByteString.Builder (byteString)
import System.IO
import Data.Function (fix)
import Control.Monad (unless)

main :: IO ()
main = run 3000 $ _req send -> withBinaryFile "Main.hs" ReadMode $ h ->
  send $ responseStream
    status200
    [("Content-Type", "text/plain")]
    $ chunk _flush -> fix $ loop -> do
      bs <- B.hGetSome h 4096
      unless (B.null bs) $ do
        chunk $ byteString bs
        loop

responseFile is better, it can use sendfile system call optimization.

Exercise Use streaming to send two files concatenated together. Now generalize that to an arbitrarily sized list.

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.ByteString.Builder (byteString)
import System.IO
import Data.Function (fix)
import Control.Monad (unless, forM_)

files :: [FilePath]
files = ["file1.txt", "file2.txt"]

withBinaryFiles :: [FilePath] -> IOMode -> ([Handle] -> IO a) -> IO a
withBinaryFiles fps mode inner =
  loop fps id
  where
    loop [] front = inner $ front []
    loop (x:xs) front =
      withBinaryFile x mode $ h ->
      loop xs (front . (h:))

main :: IO ()
main = run 3000 $ _req send -> withBinaryFiles files ReadMode $ hs ->
  send $ responseStream
    status200
    [("Content-Type", "text/plain")]
    $ chunk _flush -> forM_ hs $ h -> fix $ loop -> do
      bs <- B.hGetSome h 4096
      unless (B.null bs) $ do
        chunk $ byteString bs
        loop

Question This implementation uses too many of some resource, what is it? How can we work around it?

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.ByteString.Builder (byteString)
import System.IO
import Data.Function (fix)
import Control.Monad (unless, forM_)
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class
import UnliftIO.Exception (bracket)

files :: [FilePath]
files = ["file1.txt", "file2.txt"]

main :: IO ()
main = run 3000 $ _req send ->
  bracket createInternalState closeInternalState $ is ->
  send $ responseStream
  status200
  [("Content-Type", "text/plain")]
  $ chunk _flush -> runInternalState (forM_ files $ file -> do
      (releaseKey, h) <- allocate
        (openBinaryFile file ReadMode)
        hClose
      liftIO $ fix $ loop -> do
        bs <- B.hGetSome h 4096
        unless (B.null bs) $ do
          chunk $ byteString bs
          loop
      release releaseKey) is

aeson response body

Let’s be a little more pragmatic…

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import Data.Aeson

main :: IO ()
main = run 3000 $ _req send -> send $ responseBuilder
  status200
  [("Content-Type", "application/json")]
  $ fromEncoding $ toEncoding $ object
      [ "foo" .= (5 :: Int)
      , "bar" .= True
      ]

Exercise Send a YAML response instead. What do you think the performance difference will be here vs the code above?

aeson request body

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Network.HTTP.Simple

main :: IO ()
main = do
  let req = setRequestMethod "POST"
          $ setRequestBodyJSON (object ["hello" .= (1 :: Int)])
            "http://localhost:3000"
  res <- httpJSON req
  print (res :: Response Value)

And server code

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Conduit
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import Data.Aeson
import Data.Aeson.Parser (json)
import Data.Aeson.Types
import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser)

newtype Body = Body Int

instance ToJSON Body where
  toJSON (Body i) = object ["hello" .= i]
instance FromJSON Body where
  parseJSON = withObject "Body" $ o -> Body <$> o .: "hello"

main :: IO ()
main = run 3000 $ req send -> do
  val <- runConduit
       $ sourceRequestBody req
      .| sinkParser json
  let Success (Body i) = fromJSON val
  send $ responseBuilder
    status200
    [("Content-Type", "application/json")]
    $ fromEncoding $ toEncoding $ Body $ i + 1

Exercise Do this with much better error handling

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Conduit
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import Data.Aeson
import Data.Aeson.Parser (json)
import Data.Aeson.Types
import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser)
import UnliftIO.Exception
import qualified Data.ByteString.Lazy.Char8 as BL8

newtype Body = Body Int

instance ToJSON Body where
  toJSON (Body i) = object ["hello" .= i]
instance FromJSON Body where
  parseJSON = withObject "Body" $ o -> Body <$> o .: "hello"

main :: IO ()
main = run 3000 $ req send -> do
  eres <- tryAnyDeep $ do
    val <- runConduit
         $ sourceRequestBody req
        .| sinkParser json
    -- this is still bad! But tryAnyDeep hides it
    let Success (Body i) = fromJSON val
    return i
  send $ case eres of
    Left e -> responseLBS
      status500
      [("Content-Type", "text/plain")]
      $ BL8.pack $ "Exception occurred: " ++ show e
    Right i -> responseBuilder
      status200
      [("Content-Type", "application/json")]
      $ fromEncoding $ toEncoding $ Body $ i + 1

Throw in some middleware

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.RequestLogger
import Network.HTTP.Types

main :: IO ()
main = run 3000
  $ logStdoutDev
  $ gzip def
  $ autohead
  $ req send -> send $ responseBuilder
  status200
  (case lookup "marco" $ requestHeaders req of
     Nothing -> []
     Just val -> [("Polo", val)])
  "Hello WAI!"

Yesod?

Exercises

#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.Function (fix)
import Control.Monad (unless)
import Data.ByteString.Builder (byteString)

main :: IO ()
main = run 3000 $ req send -> send $ responseStream
  status200
  (requestHeaders req)
  $ chunk _flush -> fix $ loop -> do
    bs <- requestBody req
    unless (B.null bs) $ do
      chunk $ byteString bs
      loop

Problems:

Additional material

Subscribe to our blog via email

Email subscriptions come from our Atom feed and are handled by Blogtrottr. You will only receive notifications of blog posts, and can unsubscribe any time.