X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=a9eff98ac6c1890741ca546d7e0028c935f157c5;hb=f19a294d54f38faaeab0027ecb5d85388243b924;hp=d71b53ad75661c18561f6785be30f96d26834881;hpb=dc29dc9081156af3b536b19ffd828cdd67ddd84a;p=Rakka.git diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index d71b53a..a9eff98 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -3,12 +3,11 @@ 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 @@ -24,11 +23,7 @@ import Rakka.W3CDateTime import Rakka.Wiki.Engine import System.FilePath import Text.HyperEstraier hiding (getText) -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.XML.HXT.Arrow import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords @@ -55,19 +50,20 @@ fallbackPageEntity env path handleGet :: Environment -> PageName -> Resource () handleGet env name - = runIdempotentA $ 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 + = 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 {- @@ -87,7 +83,9 @@ handleRedirect env >>> xmlizePage >>> - writeDocumentToString [ (a_indent, v_1) ] + writeDocumentToString [ (a_indent , v_1 ) + , (a_output_encoding, utf8) + , (a_no_xml_pi , v_0 ) ] ) output resultStr @@ -103,19 +101,9 @@ handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Pa 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 [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env) - , (MIMEType "application" "rss+xml" [], entityToRSS 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 @@ -132,11 +120,9 @@ entityToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - feeds <- arrIO0 (findFeeds (envStorage env)) -< () - - pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right") pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page ( eelem "/" @@ -144,7 +130,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" @@ -160,14 +146,7 @@ entityToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) - += ( constL feeds - >>> - eelem "link" - += sattr "rel" "alternate" - += sattr "type" "application/rss+xml" - += attr "title" (txt siteName <+> txt " - " <+> mkText) - += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) - ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -180,6 +159,7 @@ entityToXHTML env += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -310,13 +290,38 @@ entityToRSS env readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree + -> 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 {- @@ -355,9 +360,9 @@ pageListingToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right") + 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" @@ -375,6 +380,7 @@ pageListingToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -386,6 +392,7 @@ pageListingToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -467,9 +474,9 @@ notFoundToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right") + 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" @@ -487,6 +494,7 @@ notFoundToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -498,6 +506,7 @@ notFoundToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -553,6 +562,20 @@ handleDelete env 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 @@ -560,9 +583,49 @@ findFeeds sto addAttrCond cond "rakka:isFeed STREQ yes" setOrder cond "@uri STRA" result <- searchPages sto cond - return (map fst result) + 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) "" \ No newline at end of file + = uriToString id (mkFeedURI baseURI name) "" + + +mkObjectURIStr :: URI -> PageName -> String +mkObjectURIStr baseURI name + = uriToString id (mkObjectURI baseURI name) ""