- toPageName = decodePageName . dropExtension . joinWith "/"
-
-
-handleGet :: Environment -> PageName -> Resource ()
-handleGet env name
- = runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< name
- case pageM of
- Nothing
- -> handlePageNotFound env -< name
-
- Just redir@(Redirection _ _ _ _)
- -> handleRedirect env -< redir
-
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
- -> handleGetEntity env -< entity
-
-{-
- HTTP/1.1 302 Found
- Location: http://example.org/Destination?from=Source
--}
-handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
-handleRedirect env
- = proc redir
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
- returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
-
-
-{-
- <page site="CieloNegro"
- styleSheet="http://example.org/object/StyleSheet/Default"
- name="Foo/Bar"
- type="text/x-rakka"
- lang="ja" -- 存在しない場合もある
- isTheme="no" -- text/css の場合のみ存在
- isFeed="no" -- text/x-rakka の場合のみ存在
- isLocked="no"
- isBinary="no"
- revision="112"> -- デフォルトでない場合のみ存在
- lastModified="2000-01-01T00:00:00">
-
- <summary>
- blah blah...
- </summary> -- 存在しない場合もある
-
- <otherLang> -- 存在しない場合もある
- <link lang="ja" page="Bar/Baz" />
- </otherLang>
-
- <pageTitle>
- blah blah...
- </pageTitle>
-
- <sideBar>
- <left>
- blah blah...
- </left>
- <right>
- blah blah...
- </right>
- </sideBar>
-
- <body>
- blah blah...
- </body>
- </page>
--}
-handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
-handleGetEntity env
- = proc page
- -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
- returnA -< do let lastMod = toClockTime $ pageLastMod page
-
- -- 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
-
- outputXmlPage tree entityToXHTML
-
-
-entityToXHTML :: ArrowXml a => a XmlTree XmlTree
-entityToXHTML
- = eelem "/"
- += ( eelem "html"
- += sattr "xmlns" "http://www.w3.org/1999/xhtml"
- += ( getXPathTreesInDoc "/page/@lang"
- `guards`
- qattr (QN "xml" "lang" "")
- ( getXPathTreesInDoc "/page/@lang/text()" )
- )
- += ( eelem "head"
- += ( eelem "title"
- += getXPathTreesInDoc "/page/@site/text()"
- += txt " - "
- += getXPathTreesInDoc "/page/@name/text()"
- )
- += ( eelem "link"
- += sattr "rel" "stylesheet"
- += sattr "type" "text/css"
- += attr "href"
- ( getXPathTreesInDoc "/page/@styleSheet/text()" )
- )
- )
- += ( eelem "body"
- += ( eelem "div"
- += sattr "class" "header"
- )
- += ( eelem "div"
- += sattr "class" "center"
- += ( eelem "div"
- += sattr "class" "title"
- += getXPathTreesInDoc "/page/pageTitle/*"
- )
- += ( eelem "div"
- += sattr "class" "body"
- += getXPathTreesInDoc "/page/body/*"
- )
- )
- += ( eelem "div"
- += sattr "class" "footer"
- )
- += ( eelem "div"
- += sattr "class" "left sideBar"
- += ( eelem "div"
- += sattr "class" "content"
- += getXPathTreesInDoc "/page/sideBar/left/*"
- )
- )
- += ( eelem "div"
- += sattr "class" "right sideBar"
- += ( eelem "div"
- += sattr "class" "content"
- += getXPathTreesInDoc "/page/sideBar/right/*"
- )
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )