respond-0.2.0.0: example/Main.hs

module Main where

import Data.Monoid ((<>))
import Control.Applicative ((<|>))
import Network.Wai
import Data.Aeson
import Network.HTTP.Types.Status
import Network.HTTP.Types.Method
import qualified Data.Text as T
import Web.Respond
import System.Log.FastLogger
import Control.Exception


main :: IO ()
main = do
    logger <- newStdoutLoggerSet defaultBufSize 
    serveRespondDefault 3000 logger id exampleApi

type Example = RespondT IO

exampleApi :: Example ResponseReceived
exampleApi = matchPath $
    path endOrSlash apiRoot <|> 
    path (seg "assemble" ) assembleHandler <|>
    path (seg "number" </> value </> seg "string" </> value </> endOrSlash) numHandler <|>
    path (seg "error" </> endOrSlash) errorExample <|>
    path (seg "methoding") methodingExample
    where
    numHandler :: Integer -> T.Text -> Example ResponseReceived
    numHandler num t = respondOk $ object ["text" .= t, "num" .= num]

assembleHandler :: Example ResponseReceived
assembleHandler = matchPath $
    path endOrSlash (respondStdHeaders notImplemented501 (object ["awaiting" .= ("stray kitten" :: T.Text)])) <|>
    path value firstHandler

apiRoot :: Example ResponseReceived
apiRoot = matchMethod $
    onGET (respondOk (object ["location" .= ("here" :: T.Text)])) <>
    onPUT (respondOk (object ["location" .= ("there" :: T.Text)])) <>
    onPOST (withRequiredBody $ showPostedValue . getJson)
    where
    showPostedValue :: Value -> Example ResponseReceived
    showPostedValue v = respondOk (object ["location" .= ("cold" :: T.Text), "recvd" .= v])

firstHandler :: T.Text -> Example ResponseReceived
firstHandler p = do 
    ps <- getUnconsumedPath
    respondStdHeaders notImplemented501 (object ["head" .= p, "tail" .= ps])

errorExample :: Example ResponseReceived
errorExample = catchRespond displayError $ matchMethod $
    onGET $ error "hey what's going on"
    where
    displayError (ErrorCall s) = errorReportWithMessage "error_thrown" (T.pack s)

textGET :: T.Text
textGET = "get"

textPOST :: T.Text
textPOST = "post"

textOne :: T.Text
textOne = "one"

textTwo :: T.Text
textTwo = "two"

methodingExample :: Example ResponseReceived
methodingExample = matchPath $
    pathEndOrSlash (matchMethod $
        onGET (respondOk $ object ["method" .= textGET]) <>
        onPOST (respondOk $ object ["method" .= textPOST])) <|>
    matchPathWithMethod GET (
        pathLastSeg "one" (respondOk $ object ["got" .= textOne]) <|>
        path (seg "two" </> (value :: PathExtractor1 Int)) (\i -> respondOk $ object ["got" .= textTwo, "v" .= i]))