X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=d99cb94ea11d858efb8a5bffcf9bfaff0e9a63a2;hb=f19a294d54f38faaeab0027ecb5d85388243b924;hp=e9929903e75fce46e92bd45fc717bbb0632c6666;hpb=1647278f9393f7382b6e8b8a5e9e14ce50aae718;p=Rakka.git diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index e992990..d99cb94 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -1,209 +1,107 @@ 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 - -> returnA -< foundNoEntity Nothing - - Just redir@(Redirection _ _ _ _) - -> handleRedirect env -< redir + toPageName = decodePageName . joinWith "/" - 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... - -- 存在しない場合もある - - -- 存在しない場合もある - - - - + --- 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 + + + foo + blah blah... - - + + -} -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 "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 "content" - += (constA page >>> formatPage env ) - ) - >>> - 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 - +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) + , (a_output_encoding, utf8) + , (a_no_xml_pi , v_0) ] + ) + 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 + ) ) -<< () -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" - ) - += ( eelem "div" - += sattr "class" "body" - += getXPathTreesInDoc "/page/content/*" - ) - ) - += ( 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 - )