where
import Control.Arrow
-import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
import Data.Char
+import qualified Data.Map as M
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Network.URI
-> do pageM <- getPageA (envStorage env) -< name
case pageM of
Nothing
- -> returnA -< foundNoEntity Nothing
+ -> handlePageNotFound env -< name
Just redir@(Redirection _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
= proc redir
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
{-
- [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"
+ lang="ja" -- 存在しない場合もある
isTheme="no" -- text/css の場合のみ存在
isFeed="no" -- text/x-rakka の場合のみ存在
isLocked="no"
revision="112"> -- デフォルトでない場合のみ存在
- lastModified="2000-01-01T00:00:00" />
+ lastModified="2000-01-01T00:00:00">
<summary>
blah blah...
<link lang="ja" page="Bar/Baz" />
</otherLang>
- <content>
+ <pageTitle>
blah blah...
- </content>
- </page>
+ </pageTitle>
-
- [pageIsBinary が True の場合: content 要素の代はりに object 要素]
-
- <object data="/object/Foo/Bar" /> -- data 屬性に URI
+ <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
- = let sysConf = envSysConf env
- in
- proc page
- -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
- BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
- StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
-
- tree <- ( eelem "/"
- += ( eelem "page"
- += sattr "site" siteName
- += sattr "baseURI" (uriToString id baseURI "")
- += sattr "styleSheet" cssName
- += sattr "name" (pageName page)
- += sattr "type" (show $ pageType page)
- += ( case pageType page of
- MIMEType "text" "css" _
- -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "x-rakka" _
- -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
- _ -> none
- )
- += sattr "isLocked" (yesOrNo $ pageIsLocked page)
- += ( case pageRevision page of
- Nothing -> none
- Just rev -> sattr "revision" (show rev)
- )
- += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
-
- += ( case pageSummary page of
- Nothing -> none
- Just s -> eelem "summary" += txt s
- )
-
- += ( case pageOtherLang page of
- [] -> none
- xs -> selem "otherLang"
+ = proc page
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
+ Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
+ Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
+
+ tree <- ( eelem "/"
+ += ( eelem "page"
+ += sattr "site" siteName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+ += sattr "name" (pageName page)
+ += sattr "type" (show $ pageType page)
+ += ( case pageLanguage page of
+ Just x -> sattr "lang" x
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "css" _
+ -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
+ _ -> none
+ )
+ += sattr "isLocked" (yesOrNo $ pageIsLocked page)
+ += ( case pageRevision page of
+ Nothing -> none
+ Just rev -> sattr "revision" (show rev)
+ )
+ += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
+
+ += ( case pageSummary page of
+ Nothing -> none
+ Just s -> eelem "summary" += txt s
+ )
+
+ += ( if M.null (pageOtherLang page) then
+ none
+ else
+ selem "otherLang"
[ eelem "link"
+= sattr "lang" lang
+= 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) "")
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
- returnA -< do let lastMod = toClockTime $ pageLastMod page
+ | (lang, page) <- M.toList (pageOtherLang page) ]
+ )
+ += ( eelem "pageTitle"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
+ >>>
+ formatSubPage env
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
+ >>>
+ formatSubPage env
+ )
+ )
+ += ( eelem "right"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
+ >>>
+ formatSubPage env
+ )
+ )
+ )
+ += ( eelem "body"
+ += (constA page >>> formatPage env)
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
- case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+ 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
+ Nothing -> foundTimeStamp lastMod
+ Just rev -> foundEntity (strongETag $ show rev) lastMod
- outputXmlPage tree entityToXHTML
+ outputXmlPage tree entityToXHTML
+ where
+ sysConf :: SystemConfig
+ sysConf = envSysConf env
entityToXHTML :: ArrowXml a => a XmlTree XmlTree
= 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 "base"
+ += ( eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+= attr "href"
- ( getXPathTreesInDoc "/page/@baseURI/text()" )
+ ( 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
+ )
+
+
+{-
+ <pageNotFound site="CieloNegro"
+ styleSheet="http://example.org/object/StyleSheet/Default"
+ name="Foo/Bar">
+
+ <pageTitle>
+ blah blah...
+ </pageTitle>
+
+ <sideBar>
+ <left>
+ blah blah...
+ </left>
+ <right>
+ blah blah...
+ </right>
+ </sideBar>
+ </pageNotFound>
+-}
+handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound env
+ = proc name
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
+ Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
+ Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
+
+ tree <- ( eelem "/"
+ += ( eelem "pageNotFound"
+ += sattr "site" siteName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+ += sattr "name" name
+
+ += ( eelem "pageTitle"
+ += ( (constA name &&& constA Nothing &&& constA pageTitle)
+ >>>
+ formatSubPage env
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA name &&& constA Nothing &&& constA leftSideBar)
+ >>>
+ formatSubPage env
+ )
+ )
+ += ( eelem "right"
+ += ( (constA name &&& constA Nothing &&& constA rightSideBar)
+ >>>
+ formatSubPage env
+ )
+ )
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
+
+ returnA -< do setStatus NotFound
+ outputXmlPage tree notFoundToXHTML
+ where
+ sysConf :: SystemConfig
+ sysConf = envSysConf env
+
+
+notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
+notFoundToXHTML
+ = eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += getXPathTreesInDoc "/pageNotFound/@site/text()"
+ += txt " - "
+ += getXPathTreesInDoc "/pageNotFound/@name/text()"
)
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
- ( txt "./object/"
- <+>
- getXPathTreesInDoc "/page/@styleSheet/text()"
- >>>
- getText
- >>>
- arr encodePageName
- >>>
- mkText
- )
+ ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
)
)
+= ( eelem "body"
+= sattr "class" "center"
+= ( eelem "div"
+= sattr "class" "title"
+ += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
)
+= ( eelem "div"
+= sattr "class" "body"
- += getXPathTreesInDoc "/page/content/*"
- += ( getXPathTreesInDoc "/page/object"
- `guards`
- eelem "object"
- += attr "data"
- ( getXPathTreesInDoc "/page/object/@data/text()" )
- )
+ += txt "404 Not Found (FIXME)" -- FIXME
)
)
+= ( eelem "div"
+= sattr "class" "footer"
)
+= ( eelem "div"
- += sattr "class" "left side-bar"
+ += sattr "class" "left sideBar"
+= ( eelem "div"
+= sattr "class" "content"
+ += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
)
)
+= ( eelem "div"
- += sattr "class" "right side-bar"
+ += sattr "class" "right sideBar"
+= ( eelem "div"
+= sattr "class" "content"
+ += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
)
)
)