Mercurial > hg > Members > toma > bulletinboard

{-# LANGUAGE OverloadedStrings #-}

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 Data.Text (Text)
import Data.Maybe (fromJust)
import Data.ByteString.Lazy.Char8 (ByteString, append, pack)
import Data.ByteString.Char8 (unpack)

routeSetting :: [([Text],(Jungle -> Query -> [Param] -> IO Response))]
routeSetting = [([], showBoard),
                (["createBoard"], createBoard),
                (["showBoardMessage"], showBoardMessage),
                (["createBoardMessage"], createBoardMessage),
                (["editMessage"], editMessage),
                (["editMessageUsingGet"], editMessageUsingGet),
                (["editMessageUsingGet2"], editMessageUsingGet2)]

showBoard :: Jungle -> Query -> [Param] -> IO Response
showBoard jungle query params = do
    node <- getRootNode jungle treeName
    return $ responseLBS status200 [("Content-type", "text/html")] $ showBoardBy node

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 :: Node -> ByteString
listOfBoard node = "<h2>list of boards</h2>" `append` getBoards node

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 = fromJust $ getAttributes a [] "name"

createBoard :: Jungle -> Query -> [Param] -> IO Response
createBoard jungle _ params = do
    createBoardBy jungle params
    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoard"

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 = unpack $ snd bname
      lb_author = pack $ unpack $ snd author -- ByteString.Lazy
      lb_key = pack $ unpack $ snd key
      lb_msg = pack $ unpack $ snd msg


addBoardtoBoardList :: String -> Node -> Node
addBoardtoBoardList bname node = node -: addc -: (addca "name" (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
    node <- getRootNode jungle st_bname
    return $ responseLBS status200 [("Content-type", "text/html")] $ showBoardMessageBy node (pack st_bname)
    where
      st_bname = unpack $ fromJust . fromJust $ lookup "bname" query

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 :: Node -> ByteString -> ByteString
getMessages node bname = foldr f "" (getChildrenWithKey node [])
  where
    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` (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
    createBoardMessageBy jungle params
    return $ responseLBS status200 [("Content-type", "text/html")] $ "createBoardMessage"

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 = unpack $ snd bname
      lb_author = pack $ unpack $ snd author -- ByteString.Lazy
      lb_key = pack $ unpack $ snd key
      lb_msg = pack $ unpack $ snd msg

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 = pack $ unpack $ fromJust . fromJust $ lookup "bname" query
      lb_uuid = pack $ unpack $ fromJust . fromJust $ lookup "uuid" query

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 = unpack $ snd bname
      id = read $ unpack $ snd uuid
      lb_author = pack $ unpack $ snd author -- ByteString.Lazy
      lb_key = pack $ unpack $ snd key
      lb_msg = pack $ unpack $ snd msg

editMessage' :: Int -> ByteString -> ByteString -> ByteString -> Node -> Node
editMessage' id author key msg node = node -: (addca "author" author) -: (addca "key" key) -: (addca "msg" msg)
  where
    addca key value node = putAttribute node [id] key value
    x -: f  = f x

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

editMessageUsingGet :: Jungle -> Query -> [Param] -> IO Response
editMessageUsingGet jungle query params = do
    editMessageUsingGetBy jungle st_bname id lb_author lb_key lb_msg
    return $ responseLBS status200 [("Content-type", "text/html")] $ "editMessage"
    where
      st_bname = unpack $ fromJust . fromJust $ lookup "bname" query
      id = read $ unpack $ fromJust . fromJust $ lookup "uuid" query
      lb_author = pack $ unpack $ fromJust . fromJust $ lookup "author" query
      lb_key = pack $ unpack $ fromJust . fromJust $ lookup "key" query
      lb_msg = pack $ unpack $ fromJust . fromJust $ lookup "msg" query

editMessageUsingGetBy jungle bname id author key msg = do
    updateRootNodeWith (editMessage' id author key msg) jungle bname

-- 書き込み後読み込む
editMessageUsingGet2 :: Jungle -> Query -> [Param] -> IO Response
editMessageUsingGet2 jungle query params = do
    editMessageUsingGetBy jungle st_bname id lb_author lb_key lb_msg
    a <- getRootNode jungle st_bname
    return $ responseLBS status200 [("Content-type", "text/html")] $ pack $ show (size a)
    where
      st_bname = unpack $ fromJust . fromJust $ lookup "bname" query
      id = read $ unpack $ fromJust . fromJust $ lookup "uuid" query
      lb_author = pack $ unpack $ fromJust . fromJust $ lookup "author" query
      lb_key = pack $ unpack $ fromJust . fromJust $ lookup "key" query
      lb_msg = pack $ unpack $ fromJust . fromJust $ lookup "msg" query
author	Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date	Tue, 11 Feb 2014 19:15:16 +0900
parents	bb7ee8f9d8d7
children