X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=3823cb4fa915f80be5b9c9c98e41a73f817fcadc;hb=df6079ca32f808d76c595e7953bff7a1dd46b10b;hp=213b0757c000c067d6664fb1ee08a960bce3aac3;hpb=602cb8599101da778f6cbb043451cfa458dff89c;p=Rakka.git diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 213b075..3823cb4 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -1,271 +1,105 @@ module Rakka.Resource.Render - ( fallbackRender + ( resRender ) where import Control.Arrow import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Data.Char +import Control.Arrow.ArrowList +import Control.Monad.Trans +import qualified Data.ByteString.Lazy as Lazy +import Data.Maybe import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils +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, 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... - - --} -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()" - ) - += ( 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 "/" {- - - - + foo + 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 - +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 - )