X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=fdc95b6bb6912d2d62f25d96e8c9c651689ee189;hp=59753d7d5fd223ceaeab59453d15fa8dc87fdd29;hb=663ba8e78d737810f5928f519af4c5697ef287a8;hpb=71f2db55513679098869de2122b5d5989dbc2be2 diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 59753d7..fdc95b6 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -3,13 +3,13 @@ module Rakka.Resource.PageEntity ) where -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList +import qualified Codec.Binary.UTF8.String as UTF8 import Control.Monad.Trans +import qualified Data.ByteString.Lazy as L hiding (ByteString) import Data.Char +import qualified Data.Map as M import Data.Maybe +import Data.Time import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI hiding (path) @@ -18,13 +18,12 @@ import Rakka.Page import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig +import Rakka.Utils +import Rakka.W3CDateTime import Rakka.Wiki.Engine import System.FilePath -import Text.XML.HXT.Arrow.Namespace -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.XmlNodeSet +import Text.HyperEstraier hiding (getText) +import Text.XML.HXT.Arrow import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords @@ -38,11 +37,11 @@ fallbackPageEntity env path = return $ Just $ ResourceDef { resUsesNativeThread = False , resIsGreedy = True - , resGet = Just $ handleGet env (toPageName path) + , resGet = Just $ handleGet env (toPageName path) , resHead = Nothing , resPost = Nothing - , resPut = Just $ handlePut env (toPageName path) - , resDelete = Nothing + , resPut = Just $ handlePut env (toPageName path) + , resDelete = Just $ handleDelete env (toPageName path) } where toPageName :: [String] -> PageName @@ -51,17 +50,21 @@ fallbackPageEntity env path handleGet :: Environment -> PageName -> Resource () handleGet env name - = runIdempotentA $ proc () - -> do pageM <- getPageA (envStorage env) -< (name, Nothing) - case pageM of - Nothing - -> handlePageNotFound env -< name + = do BaseURI baseURI <- getSysConf (envSysConf env) + runIdempotentA baseURI $ proc () + -> do pageM <- getPageA (envStorage env) -< (name, Nothing) + case pageM of + Nothing + -> do items <- getDirContentsA (envStorage env) -< (name, Nothing) + case items of + [] -> handlePageNotFound env -< name + _ -> handleGetPageListing env -< (name, items) + Just page + -> if isEntity page then + handleGetEntity env -< page + else + handleRedirect env -< page - Just redir@(Redirection _ _ _ _ _) - -> handleRedirect env -< redir - - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) - -> handleGetEntity env -< entity {- HTTP/1.1 302 Found @@ -72,14 +75,6 @@ handleRedirect env = proc redir -> returnA -< do mType <- getEntityType case mType of - MIMEType "application" "xhtml+xml" _ - -> do BaseURI baseURI <- getSysConf (envSysConf env) - let uri = mkPageFragmentURI - baseURI - (redirDest redir) - ("Redirect:" ++ redirName redir) - redirect Found uri - MIMEType "text" "xml" _ -> do setContentType mType [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail @@ -92,24 +87,21 @@ handleRedirect env ) output resultStr - _ -> fail ("internal error: getEntityType returned " ++ show mType) + _ -> do BaseURI baseURI <- getSysConf (envSysConf env) + let uri = mkPageFragmentURI + baseURI + (redirDest redir) + ("Redirect:" ++ redirName redir) + redirect Found uri handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) handleGetEntity env = proc page -> do tree <- xmlizePage -< page - returnA -< do -- text/x-rakka の場合は、内容が動的に生成され - -- てゐる可能性があるので、ETag も - -- Last-Modified も返す事が出來ない。 - case entityType page of - MIMEType "text" "x-rakka" _ - -> return () - _ -> case entityRevision page of - 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ - rev -> foundEntity (strongETag $ show rev) (entityLastMod page) - - outputXmlPage tree (entityToXHTML env) + returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env) + , (MIMEType "application" "rss+xml" [], entityToRSS env) + ] entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree @@ -118,8 +110,10 @@ entityToXHTML env -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () - name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] @@ -134,7 +128,7 @@ entityToXHTML env += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( getXPathTreesInDoc "/page/@lang" `guards` - qattr (QN "xml" "lang" "") + qattr (mkQName "xml" "lang" "") ( getXPathTreesInDoc "/page/@lang/text()" ) ) += ( eelem "head" @@ -150,6 +144,7 @@ entityToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -158,8 +153,11 @@ entityToXHTML env ) += ( eelem "script" += sattr "type" "text/javascript" - += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -199,15 +197,251 @@ entityToXHTML env ) ) -<< page +entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +entityToRSS env + = proc page + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + + name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page + pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page + + ( eelem "/" + += ( eelem "rdf:RDF" + += sattr "xmlns" "http://purl.org/rss/1.0/" + += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" + += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/" + += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/" + += ( eelem "channel" + += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "") + += ( eelem "title" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/page/@name/text()" + ) + += ( eelem "link" + += txt (uriToString id baseURI "") + ) + += ( eelem "description" + += txt (case summary of + Nothing -> "RSS Feed for " ++ siteName + Just s -> s) + ) + += ( eelem "items" + += ( eelem "rdf:Seq" + += ( constL pages + >>> + eelem "rdf:li" + += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText) + ) + ) + ) + ) + += ( constL pages + >>> + arr (\ n -> (n, Nothing)) + >>> + getPageA (envStorage env) + >>> + arr fromJust + >>> + eelem "item" + += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText) + += ( eelem "title" + += (arr entityName >>> mkText) + ) + += ( eelem "link" + += (arr (mkPageURIStr baseURI . entityName) >>> mkText) + ) + += ( arrL (\ p -> case entitySummary p of + Nothing -> [] + Just s -> [s]) + >>> + eelem "description" + += mkText + ) + += ( eelem "dc:date" + += ( arrIO (utcToLocalZonedTime . entityLastMod) + >>> + arr formatW3CDateTime + >>> + mkText + ) + ) + += ( eelem "trackback:ping" + += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText) + ) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) ) -<< page + where + mkPageURIStr :: URI -> PageName -> String + mkPageURIStr baseURI name + = uriToString id (mkPageURI baseURI name) "" + + mkTrackbackURIStr :: URI -> PageName -> String + mkTrackbackURIStr baseURI name + = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) "" + + readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, Maybe XmlTree, PageName) XmlTree readSubPage env = proc (mainPageName, mainPage, subPageName) -> - do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) - subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) - -< (mainPageName, mainPage, subPage) + do langM <- case mainPage of + Nothing + -> returnA -< Nothing + Just p + -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p + subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing) + localSubPage <- case langM of + Nothing + -> returnA -< subPage + Just l + -> localize (envStorage env) -< (l, subPage) + subPageXml <- xmlizePage -< localSubPage + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) + -< (Just mainPageName, mainPage, subPageXml) returnA -< subXHTML + where + localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page + localize sto + = proc (lang, origPage) + -> do let otherLang = entityOtherLang origPage + localName = M.lookup lang otherLang + case localName of + Nothing + -> returnA -< origPage + Just ln + -> do localPage <- getPageA sto -< (ln, Nothing) + returnA -< case localPage of + Nothing -> origPage + Just p -> p + + +{- + + + + +-} +handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ()) +handleGetPageListing env + = proc (dir, items) + -> do tree <- ( eelem "/" + += ( eelem "pageListing" + += attr "path" (arr fst >>> mkText) + += ( arrL snd + >>> + ( eelem "page" + += attr "name" (arr id >>> mkText) + ) + ) + ) + ) -< (dir, items) + returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應 + + +pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +pageListingToXHTML env + = proc pageListing + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () + + name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing + + let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] + scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + + pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") + + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/pageListing/@path/text()" + ) + += ( constL cssHref + >>> + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id >>> mkText) + ) + += mkFeedList env + += ( constL scriptSrc + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr id >>> mkText) + ) + += ( eelem "script" + += sattr "type" "text/javascript" + += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") + ) + += mkGlobalJSList env + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += ( eelem "ul" + += ( getXPathTreesInDoc "/pageListing/page/@name/text()" + >>> + eelem "li" + += ( eelem "a" + += attr "href" ( getText + >>> + arr (\ x -> uriToString id (mkPageURI baseURI x) "") + >>> + mkText + ) + += this + ) + ) + ) + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL leftSideBar + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL rightSideBar + ) + ) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) ) -<< pageListing {- @@ -222,7 +456,7 @@ handlePageNotFound env ) ) -< name returnA -< do setStatus NotFound - outputXmlPage tree (notFoundToXHTML env) + outputXmlPage' tree (notFoundToXHTML env) notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree @@ -231,6 +465,7 @@ notFoundToXHTML env -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound @@ -257,6 +492,7 @@ notFoundToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -266,7 +502,9 @@ notFoundToXHTML env += ( eelem "script" += sattr "type" "text/javascript" += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -308,7 +546,84 @@ notFoundToXHTML env handlePut :: Environment -> PageName -> Resource () handlePut env name - = runXmlA env "rakka-page-1.0.rng" $ proc tree - -> do page <- parseXmlizedPage -< (name, tree) - status <- putPageA (envStorage env) -< page - returnA -< setStatus status + = do userID <- getUserID env + runXmlA env "rakka-page-1.0.rng" $ proc tree + -> do page <- parseXmlizedPage -< (name, tree) + status <- putPageA (envStorage env) -< (userID, page) + returnA -< setStatus status + + +handleDelete :: Environment -> PageName -> Resource () +handleDelete env name + = do userID <- getUserID env + status <- deletePage (envStorage env) userID name + setStatus status + + +mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree +mkFeedList env + = proc _ -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + + feed <- unlistA <<< arrIO0 (findFeeds $ envStorage env) -< () + + ( eelem "link" + += sattr "rel" "alternate" + += sattr "type" "application/rss+xml" + += attr "title" (txt siteName <+> txt " - " <+> mkText) + += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed + + +findFeeds :: Storage -> IO [PageName] +findFeeds sto + = do cond <- newCondition + setPhrase cond "[UVSET]" + addAttrCond cond "rakka:isFeed STREQ yes" + setOrder cond "@uri STRA" + result <- searchPages sto cond + return (map hpPageName $ srPages result) + + +mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree +mkGlobalJSList env + = proc _ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () + + scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< () + pageM <- getPageA (envStorage env) -< (scriptName, Nothing) + + case pageM of + Nothing -> none -< () + Just page + | isEntity page + -> ( if entityIsBinary page then + ( eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) ) + else + ( eelem "script" + += sattr "type" "text/javascript" + += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) ) + ) -<< page + | otherwise + -> none -< () + + +findJavaScripts :: Storage -> IO [PageName] +findJavaScripts sto + = do cond <- newCondition + setPhrase cond "[UVSET]" + addAttrCond cond "@title STRBW Global/" + addAttrCond cond "@type STRBW text/javascript" + setOrder cond "@uri STRA" + result <- searchPages sto cond + return (map hpPageName $ srPages result) + + +mkFeedURIStr :: URI -> PageName -> String +mkFeedURIStr baseURI name + = uriToString id (mkFeedURI baseURI name) "" + + +mkObjectURIStr :: URI -> PageName -> String +mkObjectURIStr baseURI name + = uriToString id (mkObjectURI baseURI name) ""