Mercurial > hg > Members > toma > bulletinboard

changeset 1:616d3e6ce483

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Create the basic functions of the bulletin board
author Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date Mon, 17 Jun 2013 18:09:21 +0900
parents 622f5598f951
children 4f374ebe6b99
files App.hs RouteSetting.hs Types.hs
diffstat 3 files changed, 114 insertions(+), 17 deletions(-) [+]
line wrap: on
line diff
--- a/App.hs	Mon Jun 17 05:15:33 2013 +0900
+++ b/App.hs	Mon Jun 17 18:09:21 2013 +0900
@@ -5,7 +5,7 @@
 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 Control.Monad.Trans (lift, liftIO)
 import Data.Conduit (ResourceT)
 import Control.Concurrent.STM
 import qualified Jungle as J
--- a/RouteSetting.hs	Mon Jun 17 05:15:33 2013 +0900
+++ b/RouteSetting.hs	Mon Jun 17 18:09:21 2013 +0900
@@ -12,7 +12,9 @@
 import Data.ByteString.Lazy.UTF8 (fromString)
 import Data.ByteString.Char8 (unpack)
 import Data.Text (Text)
+import Data.Maybe (fromJust)
 import qualified Jungle as J
+import qualified Data.Map as Map
 
 
 routeSetting :: [([Text],(TJungle -> Query -> [Param] -> IO Response))]
@@ -23,25 +25,106 @@
                 (["editMessage"],editMessage)]
 
 showBoard jungle query params = do
+    current_jungle <- readTVarIO jungle
+    let responseText = showBoardJungle current_jungle
+    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
+
+showBoardJungle jungle = "<html><body><h1>BBS</h1>" `append` createBoardForm `append` listOfBoard jungle `append` "</body></html>"
+
+createBoardForm = "<form action='/createBoard' method='POST'><p>Create new board.</p><p>BoardName : <input type='text' name='bname'/><p>Author : <input type='text' name='author'/> EditKey : <input type='text' name='key'/></p><p>Message<br/> <input type='textarea' name='msg'/> </p><p><input type='submit' value='submit'/></p></form><hr/>"
+
+listOfBoard jungle = "<h2>list of boards</h2>" `append` getBoards jungle
+
+getBoards jungle = Map.foldr f "" (J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle "boards")
+  where
+    f a text = text `append` "<p><a href='/showBoardMessage?bname=" `append` (bname a) `append` "'>" `append` (bname a) `append` "</a></p>"
+    bname a = J.get (J.getAttributes a) "name"
+
+createBoard jungle query params = do
+    new_jungle <- createBoardJungle jungle params 
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoard"
+
+createBoardJungle :: TJungle -> [Param] -> IO J.Jungle
+createBoardJungle jungle [] = atomically $ readTVar jungle
+createBoardJungle jungle (bname:author:key:msg:xs) = atomically $ createBoardJungle' jungle (snd bname) (snd author) (snd key) (snd msg)
+
+createBoardJungle' tv bname author key msg = do
+    jungle <- readTVar tv
+    let
+      jungle1 = addNewChild jungle "boards" [] J.createNode
+      jungle2 = putAttribute jungle1 "boards" [(Map.size $ J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle1 "boards")] "name" (B.pack $ unpack bname)
+      jungle3 = J.createTree jungle2 (unpack bname)
+      jungle4 = addNewChildAt jungle3 (unpack bname) [] 0 J.createNode 
+      jungle5 = putAttribute jungle4 (unpack bname) [0] "author" (B.pack $ unpack author)
+      jungle6 = putAttribute jungle5 (unpack bname) [0] "key" (B.pack $ unpack key)
+      jungle7 = putAttribute jungle6 (unpack bname) [0] "msg" (B.pack $ unpack msg)
+    writeTVar tv jungle7
+    readTVar tv
+
+showBoardMessage jungle query params = do
+    current_jungle <- readTVarIO jungle
+    let bname = fromJust $ fromJust $ lookup "bname" query
+    let responseText = showBoardMessageJungle current_jungle bname
+    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
+
+showBoardMessageJungle jungle bname = "<html><body><h1>"`append` (B.pack $ unpack bname) `append` "</h1>" `append` (createBoardMessageForm (B.pack $ unpack bname)) `append` getMessages jungle bname `append` "</body></html>"
+
+createBoardMessageForm bname = "<form action='/createBoardMessage' method='POST'><p>Author : <input type='text' name='author'/><input type='hidden' name='bname' value='" `append` bname `append` "'/> EditKey : <input type='text' name='key'/></p><p>Message<br/> <input type='textarea' name='msg'/> </p><p><input type='submit' value='submit'/></p></form>"
+
+getMessages jungle bname = Map.foldrWithKey f "" (J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle (unpack bname))
+  where
+    f k a text = text `append` "<hr/><p><b>" `append` author a `append` "</b></p><p>" `append` msg a `append` "</p><small><a href='/editMessage?bname=" `append` (B.pack $ unpack bname) `append` "&uuid=" `append` (B.pack $ show k) `append` "'>edit</a></small>"
+    author a = J.get (J.getAttributes a) "author"
+    msg a = J.get (J.getAttributes a) "msg"
+
+createBoardMessage jungle query params = do
+    new_jungle <- createBoardMessageJungle jungle params 
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoardMessage"
+
+createBoardMassageJungle :: TJungle -> [Param] -> IO J.Jungle
+createBoardMassageJungle jungle [] = atomically $ readTVar jungle
+createBoardMessageJungle jungle (author:bname:key:msg:xs) = atomically $ createBoardMessageJungle' jungle (snd bname) (snd author) (snd key) (snd msg)
+
+createBoardMessageJungle' tv bname author key msg = do
+    jungle <- readTVar tv
+    let
+      jungle1 = addNewChild jungle (unpack bname) [] J.createNode 
+      size = Map.size $ J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle1 (unpack bname)
+      jungle2 = putAttribute jungle1 (unpack bname) [size] "author" (B.pack $ unpack author)
+      jungle3 = putAttribute jungle2 (unpack bname) [size] "key" (B.pack $ unpack key)
+      jungle4 = putAttribute jungle3 (unpack bname) [size] "msg" (B.pack $ unpack msg)
+    writeTVar tv jungle4
+    readTVar tv
+    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoardMessage"
+
+editMessage jungle query params = do
+    new_jungle <- editMessageJungle jungle params
+    let bname = fromJust $ fromJust $ lookup "bname" query
+    let uuid = fromJust $ fromJust $ lookup "uuid" query
+    let responseText = editMessageForm bname uuid
+    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
+
+editMessageJungle jungle [] = atomically $ readTVar jungle
+editMessageJungle jungle (author:bname:uuid:key:msg:xs) = atomically $ editMessageJungle' jungle (snd bname) (snd author) (snd key) (snd msg) (snd uuid)
+
+editMessageJungle' tv bname author key msg uuid = do
+    jungle <- readTVar tv
+    let
+      x = read $ unpack uuid
+      jungle1 = putAttribute jungle (unpack bname) [x] "author" (B.pack $ unpack author)
+      jungle2 = putAttribute jungle1 (unpack bname) [x] "key" (B.pack $ unpack key)
+      jungle3 = putAttribute jungle2 (unpack bname) [x] "msg" (B.pack $ unpack msg)
+    writeTVar tv jungle3
+    readTVar tv
+
+editMessageForm bname uuid = "<html><body><h1>edit message</h1><form method='POST'><p>Author : <input type='text' name='author'/><input type='hidden' name='bname' value='" `append` (B.pack $ unpack bname) `append` "'/><input type='hidden' name='uuid' value='" `append` (B.pack $ unpack uuid) `append` "'/> EditKey : <input type='text' name='key'/></p><p>Message<br/> <input type='textarea' name='msg'/> </p><p><input type='submit' value='submit'/></p></form></body></html>"
+
+
+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 
@@ -70,3 +153,15 @@
   where
     new_tree jungle = J.putAttribute (J.getTreeByName jungle tree_name) path key value
     new_jungle jungle = J.updateTree jungle (new_tree jungle)
+
+addNewChildAt :: J.Jungle -> String -> J.Path -> Int -> J.Node -> J.Jungle
+addNewChildAt jungle tree_name path pos node = new_jungle jungle
+  where
+    new_tree jungle = J.addNewChildAt (J.getTreeByName jungle tree_name) path pos node
+    new_jungle jungle = J.updateTree jungle (new_tree jungle)
+
+addNewChild :: J.Jungle -> String -> J.Path -> J.Node -> J.Jungle
+addNewChild jungle tree_name path node = new_jungle jungle
+  where
+    new_tree jungle = J.addNewChildAt (J.getTreeByName jungle tree_name) path ((Map.size $ J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle tree_name) + 1) node
+    new_jungle jungle = J.updateTree jungle (new_tree jungle)
--- a/Types.hs	Mon Jun 17 05:15:33 2013 +0900
+++ b/Types.hs	Mon Jun 17 18:09:21 2013 +0900
@@ -6,11 +6,13 @@
 import Control.Concurrent.STM (TVar, newTVarIO)
 import qualified Jungle as J
 
+import Data.ByteString.Lazy.Char8 (pack)
+
 type TJungle = TVar J.Jungle
 
 newJungle :: IO TJungle
 newJungle = do
     let
       jungle = J.createTree J.createJungle "boards"
-    tv <- newTVarIO jungle 
+    tv <- newTVarIO jungle
     return tv