# HG changeset patch
# User Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
# Date 1371413733 -32400
# Node ID 622f5598f951e04962c46a3745541de0eb2927c9

Initial Commit

diff -r 000000000000 -r 622f5598f951 App.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/App.hs	Mon Jun 17 05:15:33 2013 +0900
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Types
+import Routes
+import Network.Wai (Request, Response, pathInfo, queryString)
+import Network.Wai.Parse (parseRequestBody, lbsBackEnd)
+import Network.Wai.Handler.Warp (run)
+import Control.Monad.Trans (lift)
+import Data.Conduit (ResourceT)
+import Control.Concurrent.STM
+import qualified Jungle as J
+
+application :: TJungle -> Request -> ResourceT IO Response
+application jungle request = do
+    let
+      function = routes $ pathInfo request
+      query    = queryString request
+    (params, _) <- parseRequestBody lbsBackEnd request
+    lift $ function jungle query params
+
+main = do 
+    putStrLn $ "Listening on port " ++ show 3000
+    jungle <- newJungle
+    run 3000 $ application jungle
diff -r 000000000000 -r 622f5598f951 RouteSetting.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/RouteSetting.hs	Mon Jun 17 05:15:33 2013 +0900
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RouteSetting (routeSetting) where
+
+import Types
+import Network.Wai (Response, responseLBS)
+import Network.Wai.Parse (Param)
+import Network.HTTP.Types (status200)
+import Network.HTTP.Types.URI (Query)
+import Control.Concurrent.STM
+import Data.ByteString.Lazy.Char8 as B (ByteString, append, pack)
+import Data.ByteString.Lazy.UTF8 (fromString)
+import Data.ByteString.Char8 (unpack)
+import Data.Text (Text)
+import qualified Jungle as J
+
+
+routeSetting :: [([Text],(TJungle -> Query -> [Param] -> IO Response))]
+routeSetting = [([], showBoard),
+                (["createBoard"], createBoard),
+                (["showBoardMessage"],showBoardMessage),
+                (["createBoardMessage"],createBoardMessage),
+                (["editMessage"],editMessage)]
+
+showBoard jungle query params = do
+    new_jungle <- modifyJungle' jungle params
+    let responseText = makeResponseText new_jungle
+    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
+
+otherfunc jungle query params = do
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "otherfunc"
+
+createBoard jungle query params = do
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoard"
+
+showBoardMessage jungle query params = do
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "showBoardMessage"
+
+createBoardMessage jungle query params = do
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoardMessage"
+
+editMessage jungle query params = do
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "editMessage"
+
+makeResponseText :: (Show a) => a -> B.ByteString
+makeResponseText s = form `append` "<h1>Hello " `append` (toByteString s) `append` "</h1>\n"
+    where 
+      form = "<form method=\"POST\" action=\"#\"><input name=\"key\" type=\"text\"><input name=\"value\" type=\"text\"><input type=\"submit\"></form>"
+
+toByteString :: (Show a) => a -> B.ByteString
+toByteString s = fromString $ show s
+
+modifyJungle' :: TJungle -> [Param] -> IO J.Jungle
+modifyJungle' jungle [] = atomically $ readTVar jungle
+modifyJungle' jungle (key:value:xs) = atomically $ test jungle (unpack $ snd key) (unpack $ snd value)
+
+add :: TJungle -> String -> String -> STM ()
+add tv key value = do
+    jungle <- readTVar tv
+    let
+      new_jungle = putAttribute jungle "boards" [] key (B.pack value)
+    writeTVar tv new_jungle
+
+test jungle key value = do
+    add jungle key value
+    readTVar jungle
+
+putAttribute :: J.Jungle -> String -> J.Path -> String -> B.ByteString -> J.Jungle
+putAttribute jungle tree_name path key value = new_jungle jungle
+  where
+    new_tree jungle = J.putAttribute (J.getTreeByName jungle tree_name) path key value
+    new_jungle jungle = J.updateTree jungle (new_tree jungle)
diff -r 000000000000 -r 622f5598f951 Routes.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Routes.hs	Mon Jun 17 05:15:33 2013 +0900
@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Routes (routes) where
+
+import Types
+import RouteSetting
+import Network.Wai (Response, responseLBS)
+import Network.HTTP.Types (status404)
+import Network.HTTP.Types.URI (Query)
+import Network.Wai.Parse (Param)
+import Data.Text (Text)
+
+routes :: [Text] -> (TJungle -> Query -> [Param] -> IO Response)
+routes path = findRoute path routeSetting
+
+findRoute path [] = notFound
+findRoute path ((p,f):xs)
+    | path == p = f
+    | otherwise = findRoute path xs
+
+notFound _ _ _ = do
+    return $ responseLBS status404 [("Content-type", "text/html")] $ "404 - File Not Found"
+
+
+
diff -r 000000000000 -r 622f5598f951 Types.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Types.hs	Mon Jun 17 05:15:33 2013 +0900
@@ -0,0 +1,16 @@
+module Types
+( TJungle
+, newJungle
+) where
+
+import Control.Concurrent.STM (TVar, newTVarIO)
+import qualified Jungle as J
+
+type TJungle = TVar J.Jungle
+
+newJungle :: IO TJungle
+newJungle = do
+    let
+      jungle = J.createTree J.createJungle "boards"
+    tv <- newTVarIO jungle 
+    return tv