module Rakka.Resource.Render
( fallbackRender
)
where
import Control.Arrow
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Data.Char
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
-> returnA -< foundNoEntity Nothing
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
{-
[pageIsBinary が False の場合]
-- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00" />
blah blah...
-- 存在しない場合もある
-- 存在しない場合もある
blah blah...
[pageIsBinary が True の場合: content 要素の代はりに object 要素]
-- data 屬性に URI
-}
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"
[ 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
case pageRevision page of
Nothing -> foundTimeStamp lastMod
Just 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"
+= ( eelem "head"
+= ( eelem "title"
+= getXPathTreesInDoc "/page/@site/text()"
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
+= ( eelem "base"
+= attr "href"
( getXPathTreesInDoc "/page/@baseURI/text()" )
)
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
( txt "./object/"
<+>
getXPathTreesInDoc "/page/@styleSheet/text()"
>>>
getText
>>>
arr encodePageName
>>>
mkText
)
)
)
+= ( eelem "body"
+= ( eelem "div"
+= sattr "class" "header"
)
+= ( eelem "div"
+= sattr "class" "center"
+= ( eelem "div"
+= sattr "class" "title"
)
+= ( eelem "div"
+= sattr "class" "body"
+= getXPathTreesInDoc "/page/content/*"
+= ( getXPathTreesInDoc "/page/object"
`guards`
eelem "object"
+= attr "data"
( getXPathTreesInDoc "/page/object/@data/text()" )
)
)
)
+= ( eelem "div"
+= sattr "class" "footer"
)
+= ( eelem "div"
+= sattr "class" "left side-bar"
+= ( eelem "div"
+= sattr "class" "content"
)
)
+= ( eelem "div"
+= sattr "class" "right side-bar"
+= ( eelem "div"
+= sattr "class" "content"
)
)
)
>>>
uniqueNamespacesFromDeclAndQNames
)