[Many improvements including the revival of XmlAlist
pho@cielonegro.org**20070212134115] {
adddir ./src/Kirschbaum/Action
adddir ./static/rng/local
hunk ./Kirschbaum.cabal 8
-Build-Depends: base, cgi, fastcgi, mtl, network, haskelldb, hxt
+Build-Depends: base, cgi, fastcgi, mtl, network, haskelldb, hxt, parsec
addfile ./src/Kirschbaum/Action/CreateThread.hs
hunk ./src/Kirschbaum/Action/CreateThread.hs 1
+module Kirschbaum.Action.CreateThread where
+
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Monad
+import Control.Monad.Reader
+import Kirschbaum.Env
+import Kirschbaum.XmlCGI
+import Network.CGI
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.Arrow.XmlNodeSet
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+{-
+ * 入力
+
+
+ blah blah...
+ blah blah blah...
+ ABRACADABRA
+ BRACADABR
+ RACADAB
+ ACADA
+ CAD
+ A
+
+ 3600
+ ...
+
+
+
+
+ * 出力 (成功時)
+
+ HTTP/1.1 201 Created
+ Location: http://.../-/haskell/238502384/
+
+
+
+
+ * 出力 (不正入力時)
+
+ HTTP/1.1 400 Bad Request
+ Content-Type: text/plain
+
+ (RelaxNG error)
+
+
+ * 出力 (失敗時)
+
+ HTTP/1.1 403 Forbidden
+
+
+ You have already created too many threads.
+
+-}
+import Text.XML.HXT.Arrow.WriteDocument
+
+handleCreateThread :: String -> ReaderT Env (CGIT IO) CGIResult
+handleCreateThread boardId
+ = do inputXml <- getInputXml "static/rng/local/createThread.rng"
+
+ [xml] <- liftIO $ runX ( constA inputXml >>> writeDocumentToString [(a_indent, v_1)] )
+ setHeader "Content-Type" "text/plain"
+ output xml
addfile ./src/Kirschbaum/CGIError.hs
hunk ./src/Kirschbaum/CGIError.hs 1
+module Kirschbaum.CGIError
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Exception
+import Control.Monad
+import Data.Dynamic
+import Data.List
+import Data.Maybe
+import Network.CGI hiding (outputError, outputException, outputInternalServerError)
+import System.IO.Error
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+data CGIError = CGIError ErrCode [(String, String)] ErrMsg
+ deriving (Show, Typeable)
+
+type ErrCode = Int
+type ErrMsg = String
+
+
+statusString :: ErrCode -> String
+statusString code
+ = let strMap = [ (400, "Bad Request")
+ , (401, "Unauthorized")
+ , (403, "Forbidden")
+ , (404, "Not Found")
+ , (405, "Method Not Allowed")
+ , (406, "Not Acceptable")
+ , (410, "Gone")
+ , (415, "Unsupported Media Type")
+ , (422, "Unprocessable Entity")
+ , (500, "Internal Server Error")
+ , (501, "Not Implemented")
+ , (503, "Service Unavailable")
+ ]
+ in
+ fromMaybe "(Undefined Error Code)" $ lookup code strMap
+
+
+throwCGIErrorIO :: ErrCode -> [(String, String)] -> ErrMsg -> IO a
+throwCGIErrorIO code headers msg
+ = let err = CGIError code headers msg
+ exc = DynException (toDyn err)
+ in
+ throwIO exc
+
+throwCGIError :: (MonadCGI m, MonadIO m) => ErrCode -> [(String, String)] -> ErrMsg -> m a
+throwCGIError code headers msg
+ = liftIO $ throwCGIErrorIO code headers msg
+
+throwCGIErrorA :: (ArrowIO a) => ErrCode -> [(String, String)] -> ErrMsg -> a b c
+throwCGIErrorA code headers msg
+ = arrIO0 $ throwCGIErrorIO code headers msg
+
+
+errorPage :: (MonadIO m, MonadCGI m) => CGIError -> m String
+errorPage (CGIError code _ msg)
+ = do server <- getVar "SERVER_SOFTWARE"
+ host <- getVar "SERVER_NAME"
+ port <- getVar "SERVER_PORT"
+ let status = statusString code
+ title = show code ++ " " ++ status
+ sig = "Haskell CGI"
+ ++ " on " ++ fromMaybe "(unknown server)" server
+ ++ " at " ++ fromMaybe "(unknown host)" host ++ maybe "" (", port " ++) port
+ [html] <- liftIO $ runX ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title" += txt title )
+ )
+ += ( eelem "body"
+ += ( eelem "h1" += txt title )
+ += ( eelem "p" += txt msg )
+ += eelem "hr"
+ += ( eelem "address" += txt sig )
+ )
+ )
+ >>>
+ writeDocumentToString [(a_indent, v_1)]
+ )
+ return html
+
+
+outputError :: (MonadIO m, MonadCGI m) => CGIError -> m CGIResult
+outputError err@(CGIError code headers msg)
+ = do setStatus code (statusString code)
+ setHeader "Content-Type" "application/xhtml+xml"
+ mapM_ (\ (key, val) -> setHeader key val) headers
+ page <- errorPage err
+ output page
+
+
+outputNotFound :: (MonadIO m, MonadCGI m) => m CGIResult
+outputNotFound = do reqURI <- requestURI
+ outputError $ CGIError 404 [] ("The requested resource was not found: "
+ ++ show reqURI
+ )
+
+outputInternalServerError :: (MonadIO m, MonadCGI m) => String -> m CGIResult
+outputInternalServerError msg
+ = outputError $ CGIError 500 [] msg
+
+
+allowMethods :: (MonadCGI m, MonadIO m) => [String] -> m String
+allowMethods ms
+ = do let allow = concat $ intersperse ", " ms
+ method <- requestMethod
+ unless (any (== method) ms)
+ (throwCGIError 405 [("Allow", allow)]
+ ("Allowed method: " ++ allow))
+ return method
+
+
+-- 發生したのが CGIError であれば、それが要求するステータスを設定する。
+-- さうでない場合は 500 Internal Server Error を返す。
+outputException :: (MonadCGI m, MonadIO m) => Exception -> m CGIResult
+outputException exc
+ = case exc of
+ ErrorCall msg -> outputInternalServerError msg
+ IOException ioE -> outputInternalServerError $ formatIOE ioE
+ DynException dynE -> case fromDynamic dynE of
+ Just (err :: CGIError) -> outputError err
+ Nothing -> outputInternalServerError $ show exc
+ where
+ formatIOE ioE = if isUserError ioE
+ then ioeGetErrorString ioE
+ else show ioE
+
+
+handleErrors :: CGI CGIResult -> CGI CGIResult
+handleErrors = flip catchCGI outputException
hunk ./src/Kirschbaum/Env.hs 3
- , setupEnv -- (Env -> IO a) -> IO a
+ , setupEnv -- (Env -> IO a) -> IO a
+ , getSchema -- (MonadIO m) => FilePath -> ReaderT Env m (IOSArrow XmlTree XmlTree)
hunk ./src/Kirschbaum/Env.hs 7
+import Control.Monad.Reader
+import Data.HashTable as HT
hunk ./src/Kirschbaum/Env.hs 12
+import Kirschbaum.RelaxNG
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
hunk ./src/Kirschbaum/Env.hs 19
+ , rngSchemas :: HashTable FilePath (IOSArrow XmlTree XmlTree)
+
hunk ./src/Kirschbaum/Env.hs 29
+ rng <- HT.new (==) HT.hashString
hunk ./src/Kirschbaum/Env.hs 32
+ , rngSchemas = rng
hunk ./src/Kirschbaum/Env.hs 35
+getSchema :: (MonadIO m) => FilePath -> ReaderT Env m (IOSArrow XmlTree XmlTree)
+getSchema fpath
+ = do env <- asks id
+ cached <- liftIO $ HT.lookup (rngSchemas env) fpath
+ case cached of
+ Just rng -> return rng
+ Nothing -> do rng <- liftIO $ loadSchema fpath
+ liftIO $ HT.update (rngSchemas env) fpath rng
+ return rng
+
hunk ./src/Kirschbaum/RelaxNG.hs 18
- = do [schema] <- runX ( readForRelax opts path
+ = do [schema] <- runX ( setErrorMsgHandler False fail
+ >>>
+ readForRelax opts path
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 9
+import Kirschbaum.CGIError
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 22
- id="haskell"
+ boardId="haskell"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 32
-
-
+
+
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 41
- = runXmlCGI' makeTree formatBoardIndex
+ = do allowMethods ["GET"]
+ runXmlCGI makeTree formatBoardIndex
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 49
- += sattr "id" "haskell"
+ += sattr "boardId" "haskell"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 58
- += sattr "title" "blah blah..."
- += sattr "id" "9999999"
- += sattr "length" "112"
+ += sattr "title" "blah blah..."
+ += sattr "threadId" "9999999"
+ += sattr "length" "112"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 63
- += sattr "title" "blah blah blah..."
- += sattr "id" "8888888"
- += sattr "length" "58"
+ += sattr "title" "blah blah blah..."
+ += sattr "threadId" "8888888"
+ += sattr "length" "58"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 88
- [ ("board", getXPathTreesInDoc "/board/@id/text()" >>> getText) ]
+ [ ("board", getXPathTreesInDoc "/board/@boardId/text()" >>> getText) ]
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 93
- getXPathTreesInDoc "/board/@id/text()"
+ getXPathTreesInDoc "/board/@boardId/text()"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 143
- ( txt (baseHref fmtAttr ++ "-/")
+ ( txt (baseHref fmtAttr ++ "createThread/")
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 145
- getXPathTreesInDoc "/board/@id/text()"
- <+>
- txt "/createThread"
+ getXPathTreesInDoc "/board/@boardId/text()"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 148
+ += ( eelem "input"
+ += sattr "type" "hidden"
+ += sattr "name" "e"
+ += sattr "value" "createThread"
+ )
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 160
+ += sattr "type" "hidden"
+ += sattr "name" "0e"
+ += sattr "value" "title"
+ )
+ += ( eelem "input"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 167
- += sattr "name" ""
+ += sattr "name" "00t"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 175
+ += sattr "type" "hidden"
+ += sattr "name" "1e"
+ += sattr "value" "name"
+ )
+ += ( eelem "input"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 182
- += sattr "name" ""
+ += sattr "name" "10t"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 189
+ += ( eelem "input"
+ += sattr "type" "hidden"
+ += sattr "name" "2e"
+ += sattr "value" "body"
+ )
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 195
- += sattr "name" ""
+ += sattr "name" "20t"
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 227
- (getAttrValue "id" >>> mkText)
+ (getAttrValue "threadId" >>> mkText)
hunk ./src/Kirschbaum/Screen/BoardIndex.hs 236
- in genTree $< (getXPathTreesInDoc "/board/@id/text()" >>> getText)
+ in genTree $< (getXPathTreesInDoc "/board/@boardId/text()" >>> getText)
hunk ./src/Kirschbaum/Utils.hs 2
- ( splitBy -- (a -> Bool) -> [a] -> [[a]]
- , joinWith -- [a] -> [[a]] -> [a]
+ ( splitBy -- (a -> Bool) -> [a] -> [[a]]
+ , joinWith -- [a] -> [[a]] -> [a]
+ , putIntoAlist -- Eq a => [(a, b)] -> (a, b) -> [(a, b)]
hunk ./src/Kirschbaum/Utils.hs 21
+
+
+putIntoAlist :: Eq a => [(a, b)] -> (a, b) -> [(a, b)]
+putIntoAlist alist newPair@(key, _)
+ = case break (keyEq key) alist
+ of (whole, [] ) -> whole ++ [newPair]
+ (prior, _:subseq) -> prior ++ [newPair] ++ subseq
+
+
+keyEq :: Eq a => a -> (a, b) -> Bool
+keyEq key (key', _) = key == key'
addfile ./src/Kirschbaum/XmlAlist.hs
hunk ./src/Kirschbaum/XmlAlist.hs 1
+module Kirschbaum.XmlAlist
+ ( alistToXml -- [(String, String)] -> IOSArrow b XmlTree
+ ) where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Data.Char
+import Data.List
+import Data.Maybe
+import Text.ParserCombinators.Parsec
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+import Kirschbaum.Utils
+
+{- シリアライズされたノード定義 -}
+data SerialDef = SerialDef NodeRef DefBody deriving (Show, Eq)
+
+type NodeRef = [Int]
+
+data DefBody
+ = IsElement -- 値は要素名
+ | IsText -- 値はテキスト
+ | ItsAttr AttrName -- 値は屬性内容
+ deriving (Show, Eq)
+
+type AttrName = String
+
+-- ノード指定部の短かい物ほど先に評價し、更にノード種別宣言を先に評價す
+-- る。屬性宣言は後。
+instance Ord SerialDef where
+ (SerialDef node body) `compare` (SerialDef node' body')
+ = case (length node, length node') of
+ (len, len')
+ | len < len' -> LT
+ | len > len' -> GT
+ | otherwise -> body `compare` body'
+
+instance Ord DefBody where
+ IsElement `compare` ItsAttr _ = LT
+ IsElement `compare` _ = EQ
+ IsText `compare` ItsAttr _ = LT
+ IsText `compare` _ = EQ
+ ItsAttr _ `compare` IsElement = GT
+ ItsAttr _ `compare` IsText = GT
+ ItsAttr _ `compare` _ = EQ
+
+{- 中間データとして生成される簡易 XML ツリー -}
+data TmpNode
+ = TmpElement String [(TmpAttrName, TmpAttrVal)] [(TmpNodeIdx, TmpNode)]
+ | TmpText String
+ deriving Show
+
+type TmpAttrName = String
+type TmpAttrVal = String
+type TmpNodeIdx = Int
+
+{- パーサ -}
+serialDef :: Parser SerialDef
+serialDef = do node <- nodeRef
+ body <- defBody
+ eof
+ return $ SerialDef node body
+
+nodeRef :: Parser NodeRef
+nodeRef = many nodeIndex
+ where
+ nodeIndex :: Parser Int
+ nodeIndex = do idx <- try singleDigit
+ return idx
+ <|>
+ do idx <- try multiDigits
+ return idx
+
+ singleDigit :: Parser Int
+ singleDigit = do c <- digit
+ return $ (ord c) - (ord '0')
+
+ multiDigits :: Parser Int
+ multiDigits = do char '.'
+ cs <- many1 digit
+ char '.'
+ return $ read cs
+
+defBody :: Parser DefBody
+defBody = do try $ char 'e'
+ return $ IsElement
+ <|>
+ do try $ char 't'
+ return $ IsText
+ <|>
+ do try $ char '@'
+ name <- many1 anyChar
+ return $ ItsAttr name
+
+parseSerialDef :: String -> Maybe SerialDef
+parseSerialDef str = case parse serialDef "" str
+ of Right def -> Just def
+ Left err -> Nothing
+
+
+-- SerialDef として正しくないキーは捨てて、結果をソートして返す。
+alistToSerialDef :: [(String, String)] -> [(SerialDef, String)]
+alistToSerialDef = sortBy comparator . mapMaybe transformer
+ where
+ transformer :: (String, String) -> Maybe (SerialDef, String)
+ transformer (key, value) = do def <- parseSerialDef key
+ return (def, value)
+
+ comparator :: (SerialDef, String) -> (SerialDef, String) -> Ordering
+ comparator (def, _) (def', _) = def `compare` def'
+
+
+-- 簡易 XML ツリーに SerialDef を適用する。適用は SerialDef 上に定義さ
+-- れた通り、順序良く行わなければならない。
+applySerialDef :: Maybe TmpNode -> (SerialDef, String) -> Maybe TmpNode
+applySerialDef prev (def, value)
+ = case def
+ of SerialDef [] (ItsAttr attrName)
+ -> case prev
+ of Just (TmpElement tagName attrs children)
+ -> let newAttrs = putIntoAlist attrs (attrName, value)
+ in
+ Just $ TmpElement tagName newAttrs children
+ _ -> prev -- 要素でないものに屬性は付けられない。
+
+
+ SerialDef [] IsText
+ -> prev -- root をテキストにする事は出來ない。
+
+ SerialDef [idx] IsText
+ -> case prev
+ of Just (TmpElement parentTagName parentAttrs parentChildren)
+ -> let newChildren = putIntoAlist parentChildren (idx, newText)
+ newText = TmpText value
+ in
+ Just $ TmpElement parentTagName parentAttrs newChildren
+ _ -> prev -- 要素でないものにテキストは追加できない。
+
+ SerialDef [] IsElement -- root
+ -> Just $ TmpElement value [] []
+
+ SerialDef [idx] IsElement -- root 以外の要素
+ -> case prev
+ of Just (TmpElement parentTagName parentAttrs parentChildren)
+ -> let newChildren = putIntoAlist parentChildren (idx, newElement)
+ newElement = TmpElement value [] []
+ in
+ Just $ TmpElement parentTagName parentAttrs newChildren
+ _ -> prev -- 要素でないものに要素は追加できない。
+
+ SerialDef (idx:subseqRef) defBody
+ -> case prev
+ of Just (TmpElement tagName attrs children)
+ -> -- idx 番目の子ノードが存在するなら、そのノー
+ -- ドについて再歸して、その結果で問題の子ノー
+ -- ドを置き換える。
+ case lookup idx children
+ of Just child
+ -> let newChildren = putIntoAlist children (idx, newChild)
+ newChild = fromJust $ applySerialDef (Just child) (newDef, value)
+ newDef = SerialDef subseqRef defBody
+ in
+ Just $ TmpElement tagName attrs newChildren
+ _ -> prev -- 存在しない子ノードの參照
+ _ -> prev -- 要素でなければ子ノードも無い
+
+
+{- ツリーの清書 -}
+fairTree :: TmpNode -> IOSArrow b XmlTree
+
+fairTree (TmpText str)
+ = txt str
+
+fairTree (TmpElement tagName attrs children)
+ = let newAttrs = map fairAttr attrs
+ newChildren = [fairTree x | (_, x) <- children]
+ in
+ mkelem tagName newAttrs newChildren
+
+fairAttr :: (TmpAttrName, TmpAttrVal) -> IOSArrow b XmlTree
+fairAttr (name, value) = sattr name value
+
+
+{- 全部の關數をまとめる -}
+alistToXml :: [(String, String)] -> IOSArrow b XmlTree
+alistToXml alist
+ = let serialDefs = alistToSerialDef alist
+ maybeTree = foldl applySerialDef Nothing serialDefs
+ in
+ case maybeTree of
+ Just tree@(TmpElement _ _ _)
+ -> selem "/" [fairTree tree]
+ _ -> issueFatal ("Failed to construct XML Tree from the alist: " ++ show alist)
+ >>>
+ none
hunk ./src/Kirschbaum/XmlCGI.hs 7
- , runXmlCGI'
+ , runXmlCGI
+ , getInputXml -- (MonadIO m, MonadCGI m) => FilePath -> ReaderT Env m XmlTree
hunk ./src/Kirschbaum/XmlCGI.hs 15
+import qualified Data.ByteString.Lazy.Char8 as BS
hunk ./src/Kirschbaum/XmlCGI.hs 17
+import Kirschbaum.CGIError
hunk ./src/Kirschbaum/XmlCGI.hs 20
+import Kirschbaum.XmlAlist
hunk ./src/Kirschbaum/XmlCGI.hs 23
+import Network.CGI.Monad
+import Network.CGI.Protocol
+import Text.XML.HXT.Arrow.ReadDocument
hunk ./src/Kirschbaum/XmlCGI.hs 81
-runXmlCGI' :: IOSArrow XmlTree XmlTree
- -> (FormatAttr
- -> IOSArrow XmlTree XmlTree)
- -> ReaderT Env (CGIT IO) CGIResult
-runXmlCGI' produceTree formatTree
+runXmlCGI :: (MonadIO m, MonadCGI m) =>
+ IOSArrow XmlTree XmlTree
+ -> (FormatAttr
+ -> IOSArrow XmlTree XmlTree)
+ -> ReaderT Env m CGIResult
+runXmlCGI produceTree formatTree
hunk ./src/Kirschbaum/XmlCGI.hs 106
+
hunk ./src/Kirschbaum/XmlCGI.hs 116
+
+getInputReader :: (MonadCGI m) => m (IOSArrow b XmlTree)
+getInputReader
+ = do ctypeStr <- requestContentType
+ case ctypeStr of
+ Nothing -> getFailingReader 400 [] "Missing Content-Type"
+ Just str -> do ctype <- parseContentType str
+ case ctype of
+ ContentType "application" "x-www-form-urlencoded" _
+ -> getAlistReader
+ ContentType "text" "xml" _
+ -> getXmlReader
+ ContentType "application" "xml" _
+ -> getXmlReader
+ _ -> getFailingReader 415 [] ("Unsupported media type: " ++ str)
+ where
+ getAlistReader
+ = do alist <- getInputs
+ return $ alistToXml alist
+ getXmlReader
+ = do req <- liftM BS.unpack (cgiGet cgiRequestBody)
+ return $ readString [ (a_validate , v_0)
+ , (a_check_namespaces , v_1)
+ , (a_remove_whitespace, v_0)
+ ] req
+ getFailingReader code headers msg
+ = return $ throwCGIErrorA code headers msg
+
+
+-- well-formed でない時は 400 Bad Request になり、valid でない時は 422
+-- Unprocessable Entity になる。入力の型が XML でも url-encoded でもな
+-- い場合は 415 Unsupported Media Type を返す。
+getInputXml :: (MonadIO m, MonadCGI m) => FilePath -> ReaderT Env m XmlTree
+getInputXml schemaPath
+ = do reader <- getInputReader
+ validator <- getSchema schemaPath
+ [tree] <- liftIO $ runX ( setErrorMsgHandler False (throwCGIErrorIO 400 [])
+ >>>
+ reader
+ >>>
+ setErrorMsgHandler False (throwCGIErrorIO 422 [])
+ >>>
+ validator
+ )
+ return tree
+
hunk ./src/Main.hs 5
-import Network.FastCGI
+import Network.FastCGI hiding (outputNotFound, handleErrors)
hunk ./src/Main.hs 9
+import Kirschbaum.Action.CreateThread
+import Kirschbaum.CGIError
hunk ./src/Main.hs 14
-
-import Kirschbaum.MCF
-import Kirschbaum.MCF.Package
hunk ./src/Main.hs 26
- extMap = [ ("css", "text/css"),
- ("js" , "text/javascript") ]
+ extMap = [ ("css", "text/css")
+ , ("js" , "text/javascript")
+ ]
hunk ./src/Main.hs 37
- = do securityCheck pathElems
+ = do allowMethods ["GET"]
+ securityCheck pathElems
hunk ./src/Main.hs 61
--- /-/haskell/createThread ==> 新規スレッド
-handleCGI ["-", boardId, "createThread"]
- = do setHeader "Content-Type" "text/plain"
- output "FIXME: not implemented yet"
+-- /createThread/haskell ==> 新規スレッド
+handleCGI ["createThread", boardId]
+ = handleCreateThread boardId
hunk ./src/Main.hs 74
- = do reqURI <- requestURI
- outputNotFound $ show reqURI
+ = outputNotFound
addfile ./static/rng/local/createThread.rng
hunk ./static/rng/local/createThread.rng 1
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
}