X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Rakka%2FResource%2FRender.hs;h=302360e645830239f1a4fa06394cb2981b78ecc3;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=bcfd17f209f48cb526a8252247fa07c3e47f11f2;hpb=ee28059eadd401e5f9256df590bbb7491f952685;p=Rakka.git
diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index bcfd17f..302360e 100644
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -1,309 +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.ArrowIf
-import Data.Char
+import Control.Arrow.ArrowList
+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 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
- | isLower $ head $ head path = return Nothing -- å
é ã®æåãå°æåã§ãã£ã¦ã¯ãªããªã
- | 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, 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...
-
-
-
- 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()"
- )
- += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
- >>>
- eelem "link"
- += sattr "rel" "stylesheet"
- += sattr "type" "text/css"
- += attr "href"
- ( getXPathTrees "/styleSheet/@src/text()" )
- )
- += ( getXPathTreesInDoc "/page/scripts/script"
- >>>
- eelem "script"
- += sattr "type" "text/javascript"
- += attr "src"
- ( getXPathTrees "/script/@src/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 â· [String] â PageName
+ toPageName = T.pack â UTF8.decodeString â joinPath
{-
-
-
-
-
-
-
-
-
-
-
-
+ 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
-
-
-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()"
- )
- += ( getXPathTreesInDoc "/pageNotFound/styleSheets/styleSheet"
- >>>
- eelem "link"
- += sattr "rel" "stylesheet"
- += sattr "type" "text/css"
- += attr "href"
- ( getXPathTrees "/styleSheet/@src/text()" )
- )
- += ( getXPathTreesInDoc "/pageNotFound/scripts/script"
- >>>
- eelem "script"
- += sattr "type" "text/javascript"
- += attr "src"
- ( getXPathTrees "/script/@src/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
- )
+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
+ ]
+ )
+ 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
+ ) ) ⤠()