Mercurial > hg > Members > toma > bulletinboard

changeset 5:782efee9766c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
adapt bulletinboards for new Jungle
author Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date Sun, 26 Jan 2014 21:24:06 +0900
parents 1363ce4186a7
children 0d12b5e49dfd
files App.hs RouteSetting.hs Routes.hs Types.hs
diffstat 4 files changed, 128 insertions(+), 161 deletions(-) [+]
line wrap: on
line diff
--- a/App.hs	Tue Jul 02 18:33:29 2013 +0900
+++ b/App.hs	Sun Jan 26 21:24:06 2014 +0900
@@ -1,24 +1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
-
+import Jungle
 import Types
 import Routes
-import Network.Wai (Request, Response, pathInfo, queryString)
+import Network.Wai (Application, pathInfo, queryString)
 import Network.Wai.Parse (parseRequestBody, lbsBackEnd)
 import Network.Wai.Handler.Warp (run)
-import Control.Monad.Trans (lift, liftIO)
-import Data.Conduit (ResourceT)
-import Control.Concurrent.STM
-import qualified Jungle as J
+import Control.Monad.Trans (lift)
 
-application :: TJungle -> Request -> ResourceT IO Response
-application jungle request = do
-    let
+application :: Jungle -> Application
+application jungle request = do 
+    (params, _) <- parseRequestBody lbsBackEnd request
+    function jungle query params
+    where
       function = routes $ pathInfo request
       query    = queryString request
-    (params, _) <- parseRequestBody lbsBackEnd request
-    lift $ function jungle query params
 
-main = do 
+main = do
     putStrLn $ "Listening on port " ++ show 3000
-    jungle <- newJungle
+    jungle <- createJungle
+    createTree jungle treeName
     run 3000 $ application jungle
--- a/RouteSetting.hs	Tue Jul 02 18:33:29 2013 +0900
+++ b/RouteSetting.hs	Sun Jan 26 21:24:06 2014 +0900
@@ -1,167 +1,145 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module RouteSetting (routeSetting) where
+module RouteSetting
+( routeSetting
+) where
 
+import Jungle
 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 Data.Maybe (fromJust)
-import qualified Jungle as J
-import qualified Data.Map as Map
+import Data.ByteString.Lazy.Char8 as B (ByteString, append, pack)
+import Data.ByteString.Char8 as C (unpack)
 
-
-routeSetting :: [([Text],(TJungle -> Query -> [Param] -> IO Response))]
+routeSetting :: [([Text],(Jungle -> Query -> [Param] -> IO Response))]
 routeSetting = [([], showBoard),
                 (["createBoard"], createBoard),
-                (["showBoardMessage"],showBoardMessage),
-                (["createBoardMessage"],createBoardMessage),
-                (["editMessage"],editMessage)]
+                (["showBoardMessage"], showBoardMessage),
+                (["createBoardMessage"], createBoardMessage),
+                (["editMessage"], editMessage)]
 
+showBoard :: Jungle -> Query -> [Param] -> IO Response
 showBoard jungle query params = do
-    current_jungle <- readTVarIO jungle
-    let responseText = showBoardJungle current_jungle
-    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
+    node <- getRootNode jungle treeName
+    return $ responseLBS status200 [("Content-type", "text/html")] $ showBoardBy node
 
-showBoardJungle jungle = "<html><body><h1>BBS</h1>" `append` createBoardForm `append` listOfBoard jungle `append` "</body></html>"
-
+showBoardBy :: Node -> ByteString
+showBoardBy node = "<html><body><h1>BBS</h1>" `append` createBoardForm `append` listOfBoard node `append` "</body></html>"
+                 
+createBoardForm :: ByteString
 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
+listOfBoard :: Node -> ByteString
+listOfBoard node = "<h2>list of boards</h2>" `append` getBoards node
 
-getBoards jungle = Map.foldr f "" (J.getMap $ J.getChildren $ J.getRootNode $ J.getTreeByName jungle "boards")
+getBoards :: Node -> ByteString
+getBoards node = foldr f "" (getChildren node [])
   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"
+    bname a = fromJust $ getAttributes a [] "name"
 
-createBoard jungle query params = do
-    new_jungle <- createBoardJungle jungle params 
+createBoard :: Jungle -> Query -> [Param] -> IO Response
+createBoard jungle _ params = do
+    createBoardBy 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)
+createBoardBy :: Jungle -> [Param] -> IO ()
+createBoardBy jungle [] = return ()
+createBoardBy jungle (bname:author:key:msg:xs) = do
+    updateRootNodeWith (addBoardtoBoardList st_bname) jungle treeName
+    createTree jungle st_bname
+    updateRootNodeWith (createNewTree lb_author lb_key lb_msg) jungle st_bname
+    where
+      st_bname = C.unpack $ snd bname
+      lb_author = B.pack $ unpack $ snd author -- ByteString.Lazy
+      lb_key = B.pack $ unpack $ snd key
+      lb_msg = B.pack $ unpack $ 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
+addBoardtoBoardList :: String -> Node -> Node
+addBoardtoBoardList bname node = node -: addc -: (addca "name" (B.pack bname))
+  where
+    -- pathの最新の子にattributeを追加する
+    addca key value node = putAttribute node [(numOfChild node [])] key value
+    addc node = addNewChildAt node []
+    x -: f  = f x
 
+createNewTree :: ByteString -> ByteString -> ByteString -> Node -> Node
+createNewTree author key msg node = node -: addc -: (addca "author" author) -: (addca "key" key) -: (addca "msg" msg)
+  where
+    addca key value node = putAttribute node [(numOfChild node [])] key value
+    addc node = addNewChildAt node []
+    x -: f  = f x
+
+showBoardMessage :: Jungle -> Query -> [Param] -> IO Response
 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
+    node <- getRootNode jungle st_bname
+    return $ responseLBS status200 [("Content-type", "text/html")] $ showBoardMessageBy node (B.pack st_bname)
+    where
+      st_bname = C.unpack $ fromJust . fromJust $ lookup "bname" query
 
-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>"
+showBoardMessageBy :: Node -> ByteString -> ByteString
+showBoardMessageBy node bname = "<html><body><h1>" `append` bname `append` "</h1>" `append` (createBoardMessageForm bname) `append` (getMessages node bname) `append` "</body></html>"
 
+createBoardMessageForm :: ByteString -> ByteString
 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))
+getMessages :: Node -> ByteString -> ByteString
+getMessages node bname = foldr f "" (getChildrenWithKey node [])
   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"
+    f (id,node) text = text `append` "<hr/><p><b>" `append` (author node) `append` "</b></p><p>" `append` (msg node) `append` "</p><small><a href='/editMessage?bname=" `append` bname `append` "&uuid=" `append` (B.pack $ show id) `append` "'>edit</a></small>"
+    author node = fromJust $ getAttributes node [] "author"
+    msg node = fromJust $ getAttributes node [] "msg"
 
+createBoardMessage :: Jungle -> Query -> [Param] -> IO Response
 createBoardMessage jungle query params = do
-    new_jungle <- createBoardMessageJungle jungle params 
+    createBoardMessageBy 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>"
-
+createBoardMessageBy :: Jungle -> [Param] -> IO ()
+createBoardMessageBy jungle [] = return ()
+createBoardMessageBy jungle (author:bname:key:msg:xs) = do
+    updateRootNodeWith (addNewMessage lb_author lb_key lb_msg) jungle st_bname
+    where
+      st_bname = C.unpack $ snd bname
+      lb_author = B.pack $ unpack $ snd author -- ByteString.Lazy
+      lb_key = B.pack $ unpack $ snd key
+      lb_msg = B.pack $ unpack $ snd msg
 
-showBoard' jungle query params = do
-    new_jungle <- modifyJungle' jungle params
-    let responseText = makeResponseText new_jungle
-    return $ responseLBS status200 [("Content-type", "text/html")] $ responseText
-
-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)
+addNewMessage :: ByteString -> ByteString -> ByteString -> Node -> Node
+addNewMessage author key msg node = node -: addc -: (addca "author" author) -: (addca "key" key) -: (addca "msg" msg)
+  where
+    addca key value node = putAttribute node [(numOfChild node [])] key value
+    addc node = addNewChildAt node []
+    x -: f  = f x
+      
+editMessage :: Jungle -> Query -> [Param] -> IO Response
+editMessage jungle query params = do
+    editMessageBy jungle params
+    return $ responseLBS status200 [("Content-type", "text/html")] $ editMessageForm lb_bname lb_uuid
+    where
+      lb_bname = B.pack $ C.unpack $ fromJust . fromJust $ lookup "bname" query
+      lb_uuid = B.pack $ C.unpack $ fromJust . fromJust $ lookup "uuid" query
 
-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
+editMessageBy :: Jungle -> [Param] -> IO ()
+editMessageBy jungle [] = return ()
+editMessageBy jungle (author:bname:uuid:key:msg:xs) = do
+    updateRootNodeWith (editMessage' id lb_author lb_key lb_msg) jungle st_bname
+    where
+      st_bname = C.unpack $ snd bname
+      id = read $ C.unpack $ snd uuid
+      lb_author = B.pack $ unpack $ snd author -- ByteString.Lazy
+      lb_key = B.pack $ unpack $ snd key
+      lb_msg = B.pack $ unpack $ snd msg
 
-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
+editMessage' :: Int -> ByteString -> ByteString -> ByteString -> Node -> Node
+editMessage' id author key msg node = node -: (addca "author" author) -: (addca "key" key) -: (addca "msg" msg)
   where
-    new_tree jungle = J.putAttribute (J.getTreeByName jungle tree_name) path key value
-    new_jungle jungle = J.updateTree jungle (new_tree jungle)
+    addca key value node = putAttribute node [id] key value
+    x -: f  = f x
 
-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)
+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` bname `append` "'/><input type='hidden' name='uuid' value='" `append` 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>"
--- a/Routes.hs	Tue Jul 02 18:33:29 2013 +0900
+++ b/Routes.hs	Sun Jan 26 21:24:06 2014 +0900
@@ -1,16 +1,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Routes (routes) where
+module Routes
+( routes
+) where
 
+import Jungle
 import Types
 import RouteSetting
 import Network.Wai (Response, responseLBS)
+import Network.Wai.Parse (Param)
 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 :: [Text] -> (Jungle -> Query -> [Param] -> IO Response)
 routes path = findRoute path routeSetting
 
 findRoute path [] = notFound
@@ -18,8 +22,6 @@
     | path == p = f
     | otherwise = findRoute path xs
 
-notFound _ _ _ = do
+notFound :: Jungle -> Query -> [Param] -> IO Response
+notFound _ _ _ = 
     return $ responseLBS status404 [("Content-type", "text/html")] $ "404 - File Not Found"
-
-
-
--- a/Types.hs	Tue Jul 02 18:33:29 2013 +0900
+++ b/Types.hs	Sun Jan 26 21:24:06 2014 +0900
@@ -1,18 +1,8 @@
 module Types
-( TJungle
-, newJungle
+( treeName
 ) where
 
-import Control.Concurrent.STM (TVar, newTVarIO)
-import qualified Jungle as J
-
-import Data.ByteString.Lazy.Char8 (pack)
-
-type TJungle = TVar J.Jungle
+import Jungle
 
-newJungle :: IO TJungle
-newJungle = do
-    let
-      jungle = J.createTree J.createJungle "boards"
-    tv <- newTVarIO jungle
-    return tv
+treeName :: String
+treeName = "boards"