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
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
MIMEType "text" "x-rakka" _
-> return ()
_ -> case pageRevision page of
- 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) lastMod
+ 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) (pageLastMod 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"
handlePut :: Environment -> PageName -> Resource ()
-handlePut env name
+handlePut _env _name
= do xml <- input defaultLimit
setContentType $ read "text/xml"
output xml