From 663ba8e78d737810f5928f519af4c5697ef287a8 Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 31 Oct 2008 18:30:19 +0900 Subject: [PATCH] code clean up darcs-hash:20081031093019-62b54-1eb5bfcdee6f6a2d01f88802615a6d4a6d2f13e5.gz --- Rakka/Resource/PageEntity.hs | 97 +++++++++++++++++------------------- 1 file changed, 46 insertions(+), 51 deletions(-) diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 8fd0ed4..fdc95b6 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -3,7 +3,9 @@ module Rakka.Resource.PageEntity ) where +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 @@ -116,9 +118,6 @@ entityToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - feeds <- arrIO0 (findFeeds (envStorage env)) -< () - javaScripts <- arrIO0 (findJavaScripts (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") @@ -145,14 +144,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" @@ -165,12 +157,7 @@ entityToXHTML env += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) - += ( constL javaScripts - >>> - eelem "script" - += sattr "type" "text/javascript" - += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) - ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -371,9 +358,6 @@ pageListingToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - feeds <- arrIO0 (findFeeds (envStorage env)) -< () - javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< () - pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") @@ -394,14 +378,7 @@ pageListingToXHTML 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" @@ -413,12 +390,7 @@ pageListingToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) - += ( constL javaScripts - >>> - eelem "script" - += sattr "type" "text/javascript" - += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) - ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -500,9 +472,6 @@ notFoundToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - feeds <- arrIO0 (findFeeds (envStorage env)) -< () - javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< () - pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") @@ -523,14 +492,7 @@ notFoundToXHTML 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" @@ -542,12 +504,7 @@ notFoundToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) - += ( constL javaScripts - >>> - eelem "script" - += sattr "type" "text/javascript" - += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) - ) + += mkGlobalJSList env ) += ( eelem "body" += ( eelem "div" @@ -603,6 +560,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 @@ -613,6 +584,30 @@ 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 -- 2.40.0