in the middle of adding wai support

bin/bird.hs

@@ -27,7 +27,7 @@ runArg arguments =
       appModuleName <- return $ head . reverse $ split '/' appModuleNamePath
       system $ "./" ++ appModuleName
       return ()
-    ["hatch", appName] -> createBirdApp appName
+    ("hatch":appName:options) -> createBirdApp appName options
     (action:_) -> do
       putStrLn $ "Unrecognized action: " ++ (show action) ++ "\n"
       printHelp
@@ -52,15 +52,18 @@ appModuleEpilogue =
   "delete _ = status 404\n"
 
 
-createBirdApp a = do
+createBirdApp a options = do
   createDirectory a
   writeFile (a ++ "/" ++ a ++ ".bird.hs") (routeFile a)
-  writeFile (a ++ "/" ++ "Main.hs") (mainFile a)
+  let mainFileName = a ++ "/" ++ "Main.hs"
+  case options of 
+    [] -> writeFile mainFileName (mainFileHack a)
+    ["--wai"] -> writeFile mainFileName (mainFileWai a)
   putStrLn $ "A fresh Bird app has been created in " ++ a ++ "."
 
 routeFile a = "get [] = body \"Hello, Bird!\""
 
-mainFile a =
+mainFileHack a =
   "import Hack\n" ++
   "import qualified Hack as Hack\n" ++
   "import Hack.Handler.Happstack\n" ++
@@ -91,6 +94,45 @@ mainFile a =
 
   "main = run app\n"
 
+mainFileWai a = 
+  "{-# LANGUAGE OverloadedStrings #-}\n" ++
+  "import Network.Wai\n" ++
+  "import Network.Wai.Enumerator (fromLBS)\n" ++
+  "import Network.Wai.Handler.SimpleServer (run)\n" ++
+  "import Bird\n" ++
+  "import qualified Bird as Bird\n" ++
+  "import Bird.Translator.Wai\n" ++
+  "import qualified Control.Monad.State as S\n" ++
+  "import qualified Control.Monad.Reader as R\n" ++
+  "import " ++ a ++ "\n" ++ "\n" ++
+
+
+  "app :: Application\n" ++
+  "app = \\e -> route e\n\n" ++
+
+  "route :: Wai.Request -> IO Response\n" ++
+  "route e = response\n" ++
+  "  where \n" ++
+  "    req = toBirdRequest e\n" ++
+  "    response = do \n" ++
+  "      reply <- runBirdResponder req matchRequest\n" ++
+  "      return $ fromBirdReply reply\n\n" ++
+
+  "matchRequest r = \n" ++
+  "  case verb r of \n" ++
+  "    Bird.GET -> get $ path r\n" ++
+  "    Bird.POST -> post $ path r\n" ++
+  "    Bird.PUT -> put $ path r\n" ++
+  "    Bird.DELETE -> delete $ path r\n\n" ++
+
+  "main :: IO ()\n" ++
+  "main = do\n" ++
+  "    putStrLn $ \"http://localhost:8080/\"\n" ++
+  "    run 8080 app\n\n" ++
+
+
+
+
 split :: Char -> String -> [String]
 split d s
   | findSep == [] = []

src/Bird/Translator/Wai.hs

@@ -12,6 +12,7 @@ import Bird.Translator
 import Bird.Request
 import Bird.Reply
 import Bird.Request.QueryStringParser
+-- import qualified Data.ByteString.Char8 as B8
 
 instance BirdReplyTranslator Wai.Response where
   fromBirdReply r = 
@@ -32,6 +33,39 @@ instance BirdRequestTranslator Wai.Request where
     }
 
 
+
+instance BirdReplyTranslator Wai.Response where
+  fromBirdReply r = 
+    Wai.Response {
+      Wai.status = toWaiStatus $ replyStatus r,
+      Wai.responseHeaders = (Hash.toList $ Hash.insertWith insertUnlessPresent "Content-Type" "text/html" $ replyHeaders r),
+      Wai.responseBody = ResponseLBS $ replyBody r
+    }
+    where
+      insertUnlessPresent = flip const
+
+instance BirdRequestTranslator Wai.Request where
+  toBirdRequest waiRequest = 
+    Request {
+      verb = waiRequestMethodToBirdRequestMethod $ Wai.requestMethod waiRequest
+    , path = split '/' $ Wai.pathInfo e
+    , params = parseQueryString $ Wai.queryString e
+    }
+
+toWaiStatus statusCode = 
+  case statusCode of 
+    200 -> Wai.status200
+    301 -> Wai.status301
+    302 -> Wai.status302
+    303 -> Wai.status303
+    400 -> Wai.status400
+    401 -> Wai.status401 
+    403 -> Wai.status403
+    404 -> Wai.status404
+    405 -> Wai.status405
+    500 -> Wai.status500
+    _   -> Wai.Status statusCode $ "HTTP Status"
+
 waiRequestMethodToBirdRequestMethod rm = 
   case rm of 
     "GET" -> GET