module Rakka.Resource.Render ( fallbackRender ) where import Control.Arrow import Control.Arrow.ArrowIf import Control.Arrow.ArrowIO import Control.Arrow.ArrowList import Data.Char import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI 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.XmlArrow import Text.XML.HXT.Arrow.XmlNodeSet 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 } 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 {- 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 {- [pageIsBinary が False の場合] -- デフォルトでない場合のみ存在 lastModified="2000-01-01T00:00:00" /> blah blah... -- 存在しない場合もある -- 存在しない場合もある blah blah... [pageIsBinary が True の場合: content 要素の代はりに object 要素] -- data 屬性に URI -} 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 "baseURI" (uriToString id baseURI "") += sattr "styleSheet" 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 ] ) += ( case pageIsBinary page of False -> eelem "content" += (constA page >>> formatPage) True -> eelem "object" += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "") ) >>> 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 "base" += attr "href" ( getXPathTreesInDoc "/page/@baseURI/text()" ) ) += ( eelem "link" += sattr "rel" "stylesheet" += sattr "type" "text/css" += attr "href" ( txt "./object/" <+> getXPathTreesInDoc "/page/@styleSheet/text()" >>> getText >>> arr encodePageName >>> mkText ) ) ) += ( 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/*" += ( getXPathTreesInDoc "/page/object" `guards` eelem "object" += attr "data" ( getXPathTreesInDoc "/page/object/@data/text()" ) ) ) ) += ( 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 )