-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) ]
+ )
+ 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
+ ) ) -<< ()