where
import Control.Arrow
-import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Data.Char
{-
- [pageIsBinary が False の場合]
-
<page site="CieloNegro"
- baseURI="http://example.org/"
- styleSheet="StyleSheet/Default"
+ styleSheet="http://example.org/object/StyleSheet/Default"
name="Foo/Bar"
type="text/x-rakka"
isTheme="no" -- text/css の場合のみ存在
blah blah...
</content>
</page>
-
-
- [pageIsBinary が True の場合: content 要素の代はりに object 要素]
-
- <object data="/object/Foo/Bar" /> -- data 屬性に URI
-}
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
tree <- ( eelem "/"
+= ( eelem "page"
+= sattr "site" siteName
- += sattr "baseURI" (uriToString id baseURI "")
- += sattr "styleSheet" cssName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+= sattr "name" (pageName page)
+= sattr "type" (show $ pageType page)
+= ( case pageType page of
+= sattr "page" page
| (lang, page) <- xs ]
)
-
- += ( case pageIsBinary page of
- False -> eelem "content"
- += (constA page >>> formatPage)
-
- True -> eelem "object"
- += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
+ += ( eelem "content"
+ += (constA page >>> formatPage env )
)
>>>
uniqueNamespacesFromDeclAndQNames
) -<< ()
returnA -< do let lastMod = toClockTime $ pageLastMod page
-
- case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+
+ -- text/x-rakka の場合は、内容が動的に生
+ -- 成されてゐる可能性があるので、ETag も
+ -- Last-Modified も返す事が出來ない。
+ case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> return ()
+ _ -> case pageRevision page of
+ Nothing -> foundTimeStamp lastMod
+ Just rev -> foundEntity (strongETag $ show rev) lastMod
outputXmlPage tree entityToXHTML
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
- += ( eelem "base"
- += attr "href"
- ( getXPathTreesInDoc "/page/@baseURI/text()" )
- )
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
- ( txt "./object/"
- <+>
- getXPathTreesInDoc "/page/@styleSheet/text()"
- >>>
- getText
- >>>
- arr encodePageName
- >>>
- mkText
- )
+ ( getXPathTreesInDoc "/page/@styleSheet/text()" )
)
)
+= ( eelem "body"
+= ( eelem "div"
+= sattr "class" "body"
+= getXPathTreesInDoc "/page/content/*"
- += ( getXPathTreesInDoc "/page/object"
- `guards`
- eelem "object"
- += attr "data"
- ( getXPathTreesInDoc "/page/object/@data/text()" )
- )
)
)
+= ( eelem "div"