module Rakka.Resource.Render
( fallbackRender
)
where
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
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
import Rakka.Wiki.Engine
import System.FilePath
import System.Time
import Text.XML.HXT.Arrow.Namespace
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
fallbackRender env path
| null path = return Nothing
| null $ head path = return Nothing
| not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
| 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
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) (BaseURI undefined) -< ()
returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
{-
-- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00">
blah blah...
-- 存在しない場合もある
-- 存在しない場合もある
blah blah...
blah blah...
blah blah...
blah blah...
-}
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) -< ()
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) <- 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
)
) -<< ()
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
where
sysConf :: SystemConfig
sysConf = envSysConf env
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
)
{-
blah blah...
blah blah...
blah blah...
-}
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) -< ()
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"
( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
)
)
+= ( eelem "body"
+= ( eelem "div"
+= sattr "class" "header"
)
+= ( eelem "div"
+= sattr "class" "center"
+= ( eelem "div"
+= sattr "class" "title"
+= getXPathTreesInDoc "/pageNotFound/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"
+= getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
)
)
+= ( eelem "div"
+= sattr "class" "right sideBar"
+= ( eelem "div"
+= sattr "class" "content"
+= getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
)
)
)
>>>
uniqueNamespacesFromDeclAndQNames
)