complete wai/warp sample server

wai-sample.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import System.Locale
import Control.Monad.Trans

--------------------------------------------------
main :: IO ()
main = do
  let port = 3000
  putStrLn $ "starting on port " ++ show port
  run port $ makeRoutes $ notFound

--------------------------------------------------
-- match routes, call handlers
makeRoutes :: Middleware
makeRoutes app req = do
  startTime <- liftIO getCurrentTime
  -- liftIO $ print $ path req
  -- liftIO $ print $ requestMethod req
  let _path = path req
      _method = method req in
    case (_method,_path) of
      -- these are the routes
      -- an example route that captures the index
      (GET,[]) -> index req
      -- everything else gets a 404 page, via notFound above
      (_,_) -> app req
  where
    path :: Request -> [T.Text]
    path req' = filter (\c -> c /= "") $ map T.toLower $ pathInfo req
    method :: Request -> StdMethod
    method req' = case parseMethod $ requestMethod req' of
      Right m -> m
      Left _ -> GET

--------------------------------------------------
-- / handler
index :: Application
index req = do
  return $
    responseLBS status200
    [("Content-Type", "text/plain")]
    "index"

--------------------------------------------------
-- 404 fallthrough
notFound :: Application
notFound req = do
  return $
    responseLBS status404
    [("Content-Type", "text/plain")]
    "not found"