module Kirschbaum.Action.CreateThread
( resCreateThread
)
where
import Control.Arrow
import Data.Maybe
import Kirschbaum.Board
import Kirschbaum.Env
import Kirschbaum.Site
import Kirschbaum.Thread
import Kirschbaum.Utils
import Kirschbaum.XmlResource
import Network.HTTP.Lucu
import Network.URI
import System.FilePath.Posix
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
{-
* 入力
blah blah...
blah blah blah...
ABRACADABRA
BRACADABR
RACADAB
ACADA
CAD
A
3600
...
* 出力 (成功時)
HTTP/1.1 201 Created
Location: http://.../-/haskell/238502384.xml
* 出力 (失敗時)
HTTP/1.1 403 Forbidden
You have already created too many threads.
-}
{- MySQL に直接触ってゐるのでない以上、boardId が不正だった事を檢出する
爲に一旦 INSERT してみてエラーコードを確認する事は出來ない。だから板
が實在するかどうかは事前に確かめる必要がある。しかしロック方法を制御
する事は出來ないので、もしトランザクションの最中に他のスレッドが板を
消すと…？ 多分 COMMIT 時に外部キーエラーになりさう。それを防ぐ爲だ
けに SELECT で良い所を UPDATE する手も無いわけではないが、汚ないハッ
クだと思ふ。Haskell のコードには相應しくない。
-}
resCreateThread :: Env -> ResourceDef
resCreateThread env
= ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
, resGet = Nothing
, resHead = Nothing
, resPost
= Just $ do extraPath <- getPathInfo
case extraPath of
[boardId]
-> handleCreateThread env (dropExtension boardId)
_ -> foundNoEntity Nothing
, resPut = Nothing
, resDelete = Nothing
}
handleCreateThread :: Env -> String -> Resource ()
handleCreateThread env boardId
= runXmlTxA env "static/rng/local/createThread.rng" $ proc ctx
-> do let db = ctxDB ctx
tree = ctxInput ctx
redirectToOwner -< (db, (boardId, makeNewURI ctx))
title <- (getXPathTreesInDoc "/createThread/title/text()" >>> getText) -< tree
name <- maybeA (getXPathTreesInDoc "/createThread/name/text()"
>>> getText >>> deleteIfEmpty) -< tree
body <- (getXPathTreesInDoc "/createThread/body/text()"
>>> getText >>> filterNewLines) -< tree
-- FIXME: 眞面目に
let req = PostReq {
postReqName = fromMaybe "名無しさん" name
, postReqBody = body
, postReqFpr = Nothing
, postReqIpAddr = "0.0.0.0"
, postReqIsAdmin = False
, postReqIsExposed = False
, postReqIsSilent = False
}
boardInfo <- getBoardInfo -< (db, boardId)
case boardInfo of
{- FIXME: スレッド作成は樣々な要因により拒否され得る -}
Nothing
-> returnA -< foundNoEntity Nothing
Just (boardTitle, _, _, _)
-> do siteName <- getSiteName -< db
threadId <- createThread -< (db, (boardId, title))
addPost -< (db, (boardId, (threadId, req)))
touchBoard -< (db, boardId)
tree <- ( eelem "/"
+= ( eelem "createdThread"
+= sattr "site" siteName
+= sattr "boardId" boardId
+= sattr "boardTitle" boardTitle
+= sattr "threadId" (show threadId)
+= sattr "threadTitle" title
)) -<< ()
returnA -< do let baseURI = envBaseURI $ ctxEnv ctx
ext = ctxCanonicalExt ctx
setStatus Created
setLocation $ baseURI {
uriPath = joinPath [ uriPath baseURI
, "-"
, boardId
, show threadId <.> ext
]
}
outputXmlPage ctx tree formatCreatedThread
where
makeNewURI :: Context -> URI -> URI
makeNewURI ctx uri
= uri {
uriPath = joinPath [ uriPath uri
, "createThread"
, boardId <.> ctxCanonicalExt ctx
]
}
formatCreatedThread :: (ArrowXml a) => Context -> a XmlTree XmlTree
formatCreatedThread ctx
= getXPathTreesInDoc "/createdThread"
>>>
( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
+= ( (getAttrValue "site" >>> mkText)
<+>
txt " - "
<+>
(getAttrValue "boardTitle" >>> mkText)
))
+= ( eelem "base"
+= sattr "href" (show $ envBaseURI $ ctxEnv ctx)
)
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= sattr "href" "./css/common.css"
))
+= ( eelem "body"
+= ( eelem "h1"
+= (getAttrValue "boardTitle" >>> mkText)
)
+= ( eelem "p"
+= ( eelem "a"
+= attr "href"
( txt "./-/"
<+>
(getAttrValue "boardId" >>> mkText)
<+>
txt "/"
<+>
(getAttrValue "threadId" >>> mkText)
<+>
txt ".html"
)
+= getMsgNode ctx "created-thread"
[ ("title", getAttrValue "threadTitle") ]
)))))