import Control.Arrow
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
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
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"
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
= proc page
- -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
- BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
- StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
+ -> 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"
+= 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)
Just s -> eelem "summary" += txt s
)
- += ( case pageOtherLang page of
- [] -> none
- xs -> selem "otherLang"
- [ eelem "link"
- += sattr "lang" lang
- += sattr "page" page
- | (lang, page) <- xs ]
+ += ( if M.null (pageOtherLang page) then
+ none
+ else
+ selem "otherLang"
+ [ eelem "link"
+ += sattr "lang" lang
+ += sattr "page" page
+ | (lang, page) <- M.toList (pageOtherLang page) ]
)
+= ( eelem "pageTitle"
+= ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
= 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()"
handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
handlePageNotFound env
= proc name
- -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
- BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
- StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
+ -> 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"