Mercurial > hg > Papers > 2013 > toma-jssst

annotate Paper/src/warp.hs @ 3:2a4370ed68bc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
add a description of the warp
author Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date Thu, 18 Jul 2013 09:07:57 +0900
parents
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
3
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
1 {-# LANGUAGE OverloadedStrings #-}
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
2 import Network.Wai
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
3 import Network.HTTP.Types (status200, status404)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
4 import Network.Wai.Handler.Warp (run)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
5 import Control.Monad.Trans (lift)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
6 import Data.IORef (newIORef, atomicModifyIORef)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
7 import Data.ByteString.Lazy.UTF8 (fromString)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
8
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
9 application counter request = function counter
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
10 where
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
11 function = routes $ pathInfo request
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
12
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
13 routes path = findRoute path routeSetting
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
14
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
15 findRoute path [] = notFound
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
16 findRoute path ((p,f):xs)
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
17 | path == p = f
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
18 | otherwise = findRoute path xs
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
19
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
20 routeSetting = [(["hello"], hello),
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
21 (["hello","world"], world)]
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
22
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
23 notFound _ = return $
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
24 responseLBS status404 [("Content-type", "text/html")] $ "404"
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
25
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
26 hello _ = return $
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
27 responseLBS status200 [("Content-type", "text/html")] $ "hello"
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
28
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
29 world counter = do
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
30 count <- lift $ incCount counter
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
31 return $ responseLBS status200 [("Content-type", "text/html")] $
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
32 fromString $ show count
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
33
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
34 incCount counter = atomicModifyIORef counter (\c -> (c+1, c))
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
35
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
36 main = do
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
37 counter <- newIORef 0
2a4370ed68bc add a description of the warp
Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
parents:
diff changeset
38 run 3000 $ application counter