+module Rakka.Resource.PageEntity
+ ( fallbackPageEntity
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowList
+import Data.Char
+import Data.Maybe
+import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
+import Network.URI
+import Rakka.Environment
+import Rakka.Page
+import Rakka.Resource
+import Rakka.Storage
+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
+
+
+fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
+fallbackPageEntity env path
+ | null path = return Nothing
+ | null $ head path = return Nothing
+ | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
+ | otherwise
+ = return $ Just $ ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Just $ handleGet env (toPageName path)
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+ where
+ toPageName :: [String] -> PageName
+ toPageName = decodePageName . dropExtension . joinWith "/"
+
+
+handleGet :: Environment -> PageName -> Resource ()
+handleGet env name
+ = runIdempotentA $ proc ()
+ -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
+ 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
+
+
+handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
+handleGetEntity env
+ = proc page
+ -> do tree <- xmlizePage -< 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 env)
+
+
+entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+entityToXHTML env
+ = proc page
+ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
+ BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+
+ pageName <- (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")
+ pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
+
+ ( 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"
+ += txt siteName
+ += txt " - "
+ += getXPathTreesInDoc "/page/@name/text()"
+ )
+ += ( constL cssHref
+ >>>
+ eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+ += attr "href" (arr id >>> mkText)
+ )
+ += ( constL scriptSrc
+ >>>
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src" (arr id >>> mkText)
+ )
+ )
+ += ( eelem "body"
+ += ( eelem "div"
+ += sattr "class" "header"
+ )
+ += ( eelem "div"
+ += sattr "class" "center"
+ += ( eelem "div"
+ += sattr "class" "title"
+ += constL pageTitle
+ )
+ += ( eelem "div"
+ += sattr "class" "body"
+ += constL pageBody
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "footer"
+ )
+ += ( eelem "div"
+ += sattr "class" "left sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL leftSideBar
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "right sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL rightSideBar
+ )
+ )
+ )
+ ) ) -<< page
+
+
+readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a (PageName, Maybe XmlTree, PageName) XmlTree
+readSubPage env
+ = proc (mainPageName, mainPage, subPageName) ->
+ do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
+ subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
+ -< (mainPageName, mainPage, subPage)
+ returnA -< subXHTML
+
+
+{-
+ <pageNotFound name="Foo/Bar" />
+-}
+handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound env
+ = proc name
+ -> do tree <- ( eelem "/"
+ += ( eelem "pageNotFound"
+ += attr "name" (arr id >>> mkText)
+ )
+ ) -< name
+ returnA -< do setStatus NotFound
+ outputXmlPage tree (notFoundToXHTML env)
+
+
+notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+notFoundToXHTML env
+ = proc pageNotFound
+ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
+ BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+
+ pageName <- (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")
+
+ ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt siteName
+ += txt " - "
+ += getXPathTreesInDoc "/pageNotFound/@name/text()"
+ )
+ += ( constL cssHref
+ >>>
+ eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+ += attr "href" (arr id >>> mkText)
+ )
+ += ( constL scriptSrc
+ >>>
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src" (arr id >>> mkText)
+ )
+ )
+ += ( eelem "body"
+ += ( eelem "div"
+ += sattr "class" "header"
+ )
+ += ( eelem "div"
+ += sattr "class" "center"
+ += ( eelem "div"
+ += sattr "class" "title"
+ += constL pageTitle
+ )
+ += ( eelem "div"
+ += sattr "class" "body"
+ += txt "404 Not Found (FIXME)" -- FIXME
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "footer"
+ )
+ += ( eelem "div"
+ += sattr "class" "left sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL leftSideBar
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "right sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL rightSideBar
+ )
+ )
+ )
+ ) ) -<< pageNotFound