X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=c805ae5fe9af0ec4f44152c8a7e2278523ecb7a8;hb=88747f2463963ff2895a597b3054b12b2288530e;hp=3ff0bba4a9ff9529926f464cd587bf5a8779f3b1;hpb=cac96112c79075ff03dd38616a314dd293699170;p=Rakka.git diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 3ff0bba..c805ae5 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -2,18 +2,14 @@ module Rakka.Resource.PageEntity ( fallbackPageEntity ) where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList 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 qualified Data.Time.W3C as W3C import Network.HTTP.Lucu -import Network.HTTP.Lucu.Utils import Network.URI hiding (path) import Rakka.Environment import Rakka.Page @@ -21,37 +17,29 @@ import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils -import Rakka.W3CDateTime import Rakka.Wiki.Engine -import System.FilePath +import System.FilePath.Posix 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.DOM.TypeDefs -import Text.XML.HXT.DOM.XmlKeywords +import Text.XML.HXT.XPath fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef) fallbackPageEntity env path - | null path = return Nothing - | null $ head path = return Nothing - | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない + | null name = return Nothing + | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない | otherwise = return $ Just $ ResourceDef { resUsesNativeThread = False , resIsGreedy = True - , resGet = Just $ handleGet env (toPageName path) + , resGet = Just $ handleGet env name , resHead = Nothing , resPost = Nothing - , resPut = Just $ handlePut env (toPageName path) - , resDelete = Just $ handleDelete env (toPageName path) + , resPut = Just $ handlePut env name + , resDelete = Just $ handleDelete env name } where - toPageName :: [String] -> PageName - toPageName = decodePageName . dropExtension . joinWith "/" + name :: PageName + name = (dropExtension . UTF8.decodeString . joinPath) path handleGet :: Environment -> PageName -> Resource () @@ -89,7 +77,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 @@ -124,8 +114,6 @@ 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) -< (name, Just page, "PageTitle") leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left") rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right") @@ -152,14 +140,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" @@ -172,6 +153,7 @@ entityToXHTML env += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -278,7 +260,7 @@ entityToRSS env += ( eelem "dc:date" += ( arrIO (utcToLocalZonedTime . entityLastMod) >>> - arr formatW3CDateTime + arr W3C.format >>> mkText ) @@ -392,6 +374,7 @@ pageListingToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -403,6 +386,7 @@ pageListingToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -504,6 +488,7 @@ notFoundToXHTML env += sattr "type" "text/css" += attr "href" (arr id >>> mkText) ) + += mkFeedList env += ( constL scriptSrc >>> eelem "script" @@ -515,6 +500,7 @@ notFoundToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -570,6 +556,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 @@ -580,6 +580,46 @@ findFeeds sto 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) ""