module Rakka.Resource.Render
- ( fallbackRender
+ ( resRender
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
-import Data.Char
+import Control.Monad.Trans
+import qualified Data.ByteString.Lazy as Lazy
+import Data.Maybe
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
+import OpenSSL.EVP.Base64
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.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
+import Text.XML.HXT.Arrow.XmlIOStateArrow
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
- }
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+resRender :: Environment -> ResourceDef
+resRender env
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Nothing
+ , resHead = Nothing
+ , resPost = Just $ getPathInfo >>= handleRender env . toPageName
+ , 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
-
-
-{-
- <page site="CieloNegro"
- styleSheet="http://example.org/object/StyleSheet/Default"
- name="Foo/Bar"
- type="text/x-rakka"
- isTheme="no" -- text/css の場合のみ存在
- isFeed="no" -- text/x-rakka の場合のみ存在
- isLocked="no"
- revision="112"> -- デフォルトでない場合のみ存在
- lastModified="2000-01-01T00:00:00">
-
- <summary>
- blah blah...
- </summary> -- 存在しない場合もある
-
- <otherLang> -- 存在しない場合もある
- <link lang="ja" page="Bar/Baz" />
- </otherLang>
-
- <pageTitle>
- blah blah...
- </pageTitle>
-
- <sideBar>
- <left>
- blah blah...
- </left>
- <right>
- blah blah...
- </right>
- </sideBar>
-
- <body>
- blah blah...
- </body>
- </page>
--}
-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 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 ]
- )
- += ( 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"
- += ( 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
- )
+ toPageName = decodePageName . joinWith "/"
{-
- <pageNotFound site="CieloNegro"
- styleSheet="http://example.org/object/StyleSheet/Default"
+ --- Request ---
+ POST /render/Foo/Bar HTTP/1.0
+ Content-Type: text/x-rakka
+
+ = foo =
+ blah blah...
+
+ --- Response ---
+ HTTP/1.1 200 OK
+ Content-Type: text/xml
+
+ <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
name="Foo/Bar">
-
- <pageTitle>
+ <xhtml:h1>foo</xhtml:h1>
+ <xhtml:p>
blah blah...
- </pageTitle>
-
- <sideBar>
- <left>
- blah blah...
- </left>
- <right>
- blah blah...
- </right>
- </sideBar>
- </pageNotFound>
+ </xhtml:p>
+ </renderResult>
-}
-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
-
+handleRender :: Environment -> PageName -> Resource ()
+handleRender env name
+ = do entity <- inputLBS defaultLimit
+ cTypeM <- getContentType
+
+ let (bin, cType) = case cTypeM of
+ Just (MIMEType "application" "x-rakka-base64-stream" _)
+ -> let b = decodeBase64LBS entity
+ in
+ (b, guessMIMEType b)
+ Just t
+ -> (entity, t)
+ Nothing
+ -> (entity, guessMIMEType entity)
+
+ setContentType $ read "text/xml"
+ [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA (name, cType, bin)
+ >>>
+ render env
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output xmlStr
+
+
+render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
+render env
+ = proc (pName, pType, pBin)
+ -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
+ -< (pName, pType, pBin)
+
+ ( eelem "/"
+ += ( eelem "renderResult"
+ += sattr "name" pName
+ += constL pageBody
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ ) ) -<< ()
-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
- )
projects / Rakka.git / blobdiff