import Data.Maybe
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
+import Network.URI hiding (path)
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.SystemConfig
import Rakka.Wiki.Engine
import System.FilePath
-import System.Time
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
, resGet = Just $ handleGet env (toPageName path)
, resHead = Nothing
, resPost = Nothing
- , resPut = Nothing
+ , resPut = Just $ handlePut env (toPageName path)
, resDelete = Nothing
}
where
Nothing
-> handlePageNotFound env -< name
- Just redir@(Redirection _ _ _ _)
+ Just redir@(Redirection _ _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
handleGetEntity env
= proc page
-> do tree <- xmlizePage -< page
- returnA -< do let lastMod = toClockTime $ pageLastMod page
-
- -- text/x-rakka の場合は、内容が動的に生成され
+ returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
-- てゐる可能性があるので、ETag も
-- Last-Modified も返す事が出來ない。
- case pageType page of
+ case entityType page of
MIMEType "text" "x-rakka" _
-> return ()
- _ -> case pageRevision page of
- 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) lastMod
+ _ -> case entityRevision page of
+ 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
outputXmlPage tree (entityToXHTML env)
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
- pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+ name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (pageName, Just page, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Right")
+ pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
( eelem "/"
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
- pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
+ name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (pageName, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Right")
+ pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
( eelem "/"
+= ( eelem "html"
)
)
) ) -<< pageNotFound
+
+
+handlePut :: Environment -> PageName -> Resource ()
+handlePut env name
+ = runXmlA env "rakka-page-1.0.rng" $ proc tree
+ -> do page <- parseXmlizedPage -< (name, tree)
+ status <- putPageA (envStorage env) -< page
+ returnA -< setStatus status