let's build a servant

0Main.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

module Main where

import Data.Text (Text)
import Network.HTTP.Types (status200)
import Network.Wai (Application, responseLBS)
import Network.Wai.Handler.Warp (run)

import Data.Aeson
import Data.Aeson.TH

data Be a
data User =
  User { hopes :: [Text] , fears :: [Text] }

-- | The type of our RESTful service
type API =
  Be [User]

-- | ToJSON and FromJSON instances for our model type
deriveJSON defaultOptions ''User

-- | Monadic function implements the service
imp :: IO [User]
imp =
  return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"]
         , User ["oldies", "punk"] ["half-tries", "equivocation"]
         ]

-- | Marrying type and function to produce an Application
serve :: ToJSON a => Be a -> IO a -> Application
serve _ contentM = \request respond -> do
  content <- contentM
  respond . responseLBS status200 [] . encode $ content

main :: IO ()
main =
  run 2016 (serve undefined imp)

1Main.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

module Main where

import Data.Proxy (Proxy(..))
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types (status200)
import Network.Wai (Application, responseLBS, pathInfo)
import Network.Wai.Handler.Warp (run)

import Control.Lens
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.TH
import Data.Text.Strict.Lens

data RoutingFailure =
  RoutingFailure
  deriving (Show)

data Be a

data path :> rest
infixr 9 :>

data left :<|> right =
  left :<|> right
infixr 8 :<|>

data User =
  User { hopes :: [Text] , fears :: [Text] }

-- | The type of our RESTful service
type API =
       "users" :> Be [User]
  :<|> "temperature" :> Be Int

-- | ToJSON and FromJSON instances for our model type
deriveJSON defaultOptions ''User

instance Exception RoutingFailure where

-- | Two monadic functions glued together implement the service
imp :: IO [User] :<|> IO Int
imp =
  users :<|> temperature
  where
    users =
      return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"]
             , User ["oldies", "punk"] ["half-tries", "equivocation"]
             ]
    temperature =
      return 72

class ToApplication api where
  type Content api
  serve :: api -> Content api -> Application

instance ToJSON a => ToApplication (Be a) where
  type Content (Be a) = IO a
  serve _ contentM = \request respond -> do
    content <- contentM
    respond . responseLBS status200 [] . encode $ content

instance (KnownSymbol path, ToApplication rest) => ToApplication (path :> rest) where
  type Content (path :> rest) = Content rest
  serve _ contentM = \request respond -> do
    case pathInfo request of
      (first:pathInfoTail)
        | view unpacked first == symbolVal (Proxy :: Proxy path) -> do
            let subrequest = request { pathInfo = pathInfoTail }
            serve (undefined :: rest) contentM subrequest respond
      _ ->
        throwM RoutingFailure

instance (ToApplication left, ToApplication right) => ToApplication (left :<|> right) where
  type Content (left :<|> right) = Content left :<|> Content right
  serve _ (leftM :<|> rightM) = \request respond -> do
    let handler (_ :: RoutingFailure) =
          serve (undefined :: right) rightM request respond
    catch (serve (undefined :: left) leftM request respond) handler

main :: IO ()
main =
  run 2016 (serve (undefined :: API) imp)

2Main.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Main where

import Data.ByteString (ByteString)
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types (status200, status406)
import Network.Wai (Application, responseLBS, pathInfo, requestHeaders)
import Network.Wai.Handler.Warp (run)

import Control.Applicative
import Control.Lens
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.TH
import Data.Text.Strict.Lens

data RoutingFailure =
  RoutingFailure
  deriving (Show)

data Be (contentTypes :: [*]) a

data English
data Haskell
data JSON

data path :> rest
infixr 9 :>

data left :<|> right =
  left :<|> right
infixr 8 :<|>

data User =
  User { hopes :: [Text] , fears :: [Text] }
  deriving (Show)

-- | The type of our RESTful service
type API =
       "users" :> Be [JSON, Haskell] [User]
  :<|> "temperature" :> Be [JSON, English] Int

-- | ToJSON and FromJSON instances for our model type
deriveJSON defaultOptions ''User

instance Exception RoutingFailure where

-- | Two monadic functions glued together implement the service
imp :: IO [User] :<|> IO Int
imp =
  users :<|> temperature
  where
    users =
      return [ User ["ketchup", "eggs"] ["xenophobia", "reactionaries"]
             , User ["oldies", "punk"] ["half-tries", "equivocation"]
             ]
    temperature =
      return 72

class ToApplication api where
  type Content api
  serve :: api -> Content api -> Application

class ToBody (gives :: [*]) a where
  toBody :: Proxy gives -> [ByteString] -> a -> Maybe ByteString

instance ToBody '[] a where
  toBody Proxy _ _ = Nothing

instance (Give first a, ToBody rest a) => ToBody (first ': rest) a where
  toBody Proxy accepted value =
    give (Proxy :: Proxy first) accepted value
      <|> toBody (Proxy :: Proxy rest) accepted value

class Give give a where
  give :: Proxy give -> [ByteString] -> a -> Maybe ByteString

instance ToJSON a => Give JSON a where
  give Proxy accepted value =
    if elem "application/json" accepted then
      Just (view strict (encode value))
    else
      Nothing

instance (a ~ Int) => Give English a where
  give Proxy accepted value =
    if elem "text/english" accepted then
      Just (toEnglish value)
    else
      Nothing
    where
      toEnglish 0 = "zero"
      toEnglish 1 = "one"
      toEnglish 2 = "two"
      toEnglish 72 = "seventy two"
      toEnglish _ = "lots"

instance Show a => Give Haskell a where
  give Proxy accepted value =
    if elem "text/haskell" accepted then
      Just (view (packed . re utf8) (show value))
    else
      Nothing

instance (ToBody gives a) => ToApplication (Be gives a) where
  type Content (Be gives a) = IO a
  serve _ contentM = \request respond -> do
    content <- contentM
    let accepts = [value | ("accept", value) <- requestHeaders request]
    case toBody (Proxy :: Proxy gives) accepts content of
      Just bytes ->
        respond (responseLBS status200 [] (view lazy bytes))
      Nothing ->
        respond (responseLBS status406 [] "bad accept header")

instance (KnownSymbol path, ToApplication rest) => ToApplication (path :> rest) where
  type Content (path :> rest) = Content rest
  serve _ contentM = \request respond -> do
    case pathInfo request of
      (first:pathInfoTail)
        | view unpacked first == symbolVal (Proxy :: Proxy path) -> do
            let subrequest = request { pathInfo = pathInfoTail }
            serve (undefined :: rest) contentM subrequest respond
      _ ->
        throwM RoutingFailure

instance (ToApplication left, ToApplication right) => ToApplication (left :<|> right) where
  type Content (left :<|> right) = Content left :<|> Content right
  serve _ (leftM :<|> rightM) = \request respond -> do
    let handler (_ :: RoutingFailure) =
          serve (undefined :: right) rightM request respond
    catch (serve (undefined :: left) leftM request respond) handler

main :: IO ()
main =
  run 2016 (serve (undefined :: API) imp)