warp wai server echo request back

Server.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Network.Wai (
    Middleware, Request, 
    httpVersion, rawPathInfo, pathInfo, 
    requestHeaders, requestMethod, Application, responseLBS
    )
import Network.Wai.Handler.Warp (
    run
    )
import Network.HTTP.Types (
    StdMethod(GET), parseMethod, status200, status404,
    httpMajor, httpMinor, renderStdMethod
    )
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BLazy
import qualified Data.ByteString.Char8 as BChar8
import Data.Time.Clock (
    getCurrentTime
    )
import Control.Monad.Trans (
    liftIO
    )
import System.Console.GetOpt (
    ArgOrder(Permute), getOpt, usageInfo, OptDescr(Option), ArgDescr(OptArg)
    )
import System.Environment (
    getArgs, getProgName
    )
import Data.Maybe (
    fromMaybe
    )
import Data.CaseInsensitive (original)

data Arg 
    = ArgPort Int
    deriving (Eq, Show)

defaultPort = 5000

parseArgs prog args = case getOpt Permute options args of
    (o, n, []) -> return (o, n)
    (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
  where
    header = "Usage: " ++ prog ++ " [options]"
    options = [
        Option ['p'] ["port"] (OptArg port "Int") "port to listen to"
        ]
    port = ArgPort . read . fromMaybe (show defaultPort)

getPort options = case options of
    [] -> defaultPort
    (ArgPort port:xs) -> port
    --(_:xs) -> getPort xs

--------------------------------------------------
main :: IO ()
main = do
    prog <- getProgName
    args <- getArgs
    (options, _) <- parseArgs prog args
    let port = getPort options
    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


showRequest req = BLazy.fromChunks ([
    requestMethod req,
    " ",
    rawPathInfo req,
    " HTTP/", 
    BChar8.pack (show $ httpMajor ver),
    ".", 
    BChar8.pack (show $ httpMinor ver),
    "\n"
    ] ++ getHeaders (requestHeaders req))
  where
    a <> b = B.append a b
    ver = httpVersion req
    getHeaders l = case l of
        [] -> []
        ((k,v):kvs) -> original k <> ": " <> v <> "\n" : getHeaders kvs

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

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