code clean up

darcs-hash:20081031093019-62b54-1eb5bfcdee6f6a2d01f88802615a6d4a6d2f13e5.gz

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 8fd0ed4d4024b39cc851a6ec88b4441225ef8c8b..fdc95b6bb6912d2d62f25d96e8c9c651689ee189 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -3,7 +3,9 @@ module Rakka.Resource.PageEntity
     )
     where
 
     )
     where
 

+import qualified Codec.Binary.UTF8.String as UTF8

 import           Control.Monad.Trans
 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.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" }) ""]
 
           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")
           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)
                          )
                            += 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"
                       += ( constL scriptSrc
                            >>>
                            eelem "script"


@@ -165,12 +157,7 @@ entityToXHTML env
                            += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
                          )
                            += 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"
                     )
                  += ( 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" }) ""]
 
           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")
           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)
                          )
                            += 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"
                       += ( constL scriptSrc
                            >>>
                            eelem "script"


@@ -413,12 +390,7 @@ pageListingToXHTML env
                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
                          )
                            += 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"
                     )
                  += ( 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" }) ""]
 
           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")
           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)
                          )
                            += 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"
                       += ( constL scriptSrc
                            >>>
                            eelem "script"


@@ -542,12 +504,7 @@ notFoundToXHTML env
                            += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
                          )
                            += 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"
                     )
                  += ( eelem "body"
                       += ( eelem "div"


@@ -603,6 +560,20 @@ handleDelete env name
          setStatus status
 
 
          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
 findFeeds :: Storage -> IO [PageName]
 findFeeds sto
     = do cond <- newCondition


@@ -613,6 +584,30 @@ findFeeds sto
          return (map hpPageName $ srPages 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
 findJavaScripts :: Storage -> IO [PageName]
 findJavaScripts sto
     = do cond <- newCondition