X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=302360e645830239f1a4fa06394cb2981b78ecc3;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=e9929903e75fce46e92bd45fc717bbb0632c6666;hpb=1647278f9393f7382b6e8b8a5e9e14ce50aae718;p=Rakka.git diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index e992990..302360e 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -1,209 +1,110 @@ +{-# LANGUAGE + Arrows + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Resource.Render - ( fallbackRender + ( resRender ) where - +import qualified Codec.Binary.UTF8.String as UTF8 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList -import Data.Char +import Control.Arrow.Unicode +import Control.Monad.Trans +import Control.Monad.Unicode +import qualified Data.ByteString.Lazy as Lazy +import Data.Text as T import Network.HTTP.Lucu -import Network.HTTP.Lucu.Utils -import Network.URI +import OpenSSL.EVP.Base64 +import Prelude.Unicode 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 System.FilePath.Posix 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.XmlState 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 - } +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 - - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _) - -> handleGetEntity env -< entity + toPageName ∷ [String] → PageName + toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath {- - 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 ] +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 [ withIndent yes + , withXmlPi yes + ] ) - += ( 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 - - -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 - ) + output $ UTF8.encodeString xmlStr + +render ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → (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 "xmlns:xhtml" "http://www.w3.org/1999/xhtml" + += sattr "name" (T.unpack pName) + += constL pageBody + ⋙ + uniqueNamespacesFromDeclAndQNames + ) ) ⤛ ()