diff paper/src/warp.hs @ 13:17676e245515

add warp
author Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date Thu, 30 Jan 2014 17:29:07 +0900
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/paper/src/warp.hs	Thu Jan 30 17:29:07 2014 +0900
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Network.Wai
+import Network.HTTP.Types (status200, status404)
+import Network.Wai.Handler.Warp (run)
+import Control.Monad.Trans (lift)
+import Data.IORef (newIORef, atomicModifyIORef)
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+application counter request = function counter
+  where
+    function = routes $ pathInfo request
+
+routes path = findRoute path routeSetting
+
+findRoute path [] = notFound
+findRoute path ((p,f):xs)
+    | path == p = f
+    | otherwise = findRoute path xs
+
+routeSetting = [(["hello"], hello),
+                (["hello","world"], world)]
+
+notFound _ = return $
+    responseLBS status404 [("Content-type", "text/html")] $ "404"
+
+hello _ = return $
+    responseLBS status200 [("Content-type", "text/html")] $ "hello"
+
+world counter = do
+    count <- lift $ incCount counter
+    return $ responseLBS status200 [("Content-type", "text/html")] $
+      fromString $ show count
+
+incCount counter = atomicModifyIORef counter (\c -> (c+1, c))
+
+main = do
+  counter <- newIORef 0
+  run 3000 $ application counter