module Rakka.Resource.Render
( fallbackRender
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
import Data.Char
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
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.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
| 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
{-
-- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00">
blah blah...
-- 存在しない場合もある
-- 存在しない場合もある
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 tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< 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
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()"
)
+= ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
>>>
eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
( getXPathTrees "/styleSheet/@src/text()" )
)
+= ( getXPathTreesInDoc "/page/scripts/script"
>>>
eelem "script"
+= sattr "type" "text/javascript"
+= attr "src"
( getXPathTrees "/script/@src/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 tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
returnA -< do setStatus NotFound
outputXmlPage tree notFoundToXHTML
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()"
)
+= ( getXPathTreesInDoc "/pageNotFound/styleSheets/styleSheet"
>>>
eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
( getXPathTrees "/styleSheet/@src/text()" )
)
+= ( getXPathTreesInDoc "/pageNotFound/scripts/script"
>>>
eelem "script"
+= sattr "type" "text/javascript"
+= attr "src"
( getXPathTrees "/script/@src/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
)