# HG changeset patch # User Daichi TOMA # Date 1390739046 -32400 # Node ID 782efee9766c3b172153285f793791a9685adf35 # Parent 1363ce4186a71b0d47f723ddf24016eab7396ec4 adapt bulletinboards for new Jungle diff -r 1363ce4186a7 -r 782efee9766c App.hs --- 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 diff -r 1363ce4186a7 -r 782efee9766c RouteSetting.hs --- 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 = "

BBS

" `append` createBoardForm `append` listOfBoard jungle `append` "" - +showBoardBy :: Node -> ByteString +showBoardBy node = "

BBS

" `append` createBoardForm `append` listOfBoard node `append` "" + +createBoardForm :: ByteString createBoardForm = "

" -listOfBoard jungle = "

list of boards

" `append` getBoards jungle +listOfBoard :: Node -> ByteString +listOfBoard node = "

list of boards

" `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` "

" `append` (bname a) `append` "

" - 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 = "

"`append` (B.pack $ unpack bname) `append` "

" `append` (createBoardMessageForm (B.pack $ unpack bname)) `append` getMessages jungle bname `append` "" +showBoardMessageBy :: Node -> ByteString -> ByteString +showBoardMessageBy node bname = "

" `append` bname `append` "

" `append` (createBoardMessageForm bname) `append` (getMessages node bname) `append` "" +createBoardMessageForm :: ByteString -> ByteString createBoardMessageForm bname = "" -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` "

" `append` author a `append` "

" `append` msg a `append` "

edit" - author a = J.get (J.getAttributes a) "author" - msg a = J.get (J.getAttributes a) "msg" + f (id,node) text = text `append` "

" `append` (author node) `append` "

" `append` (msg node) `append` "

edit" + 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 = "

edit message

" - +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` "

Hello " `append` (toByteString s) `append` "

\n" - where - 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 = "

edit message

" diff -r 1363ce4186a7 -r 782efee9766c Routes.hs --- 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" - - - diff -r 1363ce4186a7 -r 782efee9766c Types.hs --- 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"