Mercurial > hg > Members > toma > bulletinboard
changeset 1:616d3e6ce483
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