From: pho <pho@cielonegro.org>
Date: Wed, 6 Feb 2008 08:50:15 +0000 (+0900)
Subject: implemented pager
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=8d621fced0d1b3f66d38b16cd732fd2342622c5d;p=Rakka.git

implemented pager

darcs-hash:20080206085015-62b54-10660d6cad7328627e769ddca1bd67e6b67ae28c.gz
---

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 00406c2..5d7ef68 100644
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -12,6 +12,7 @@ module Rakka.Page
     , pageUpdateInfo
     , pageRevision
 
+    , isSafeChar
     , encodePageName
     , decodePageName
 
@@ -151,14 +152,14 @@ encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 mkPageURI :: URI -> PageName -> URI
 mkPageURI baseURI name
     = baseURI {
-        uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "html"
+        uriPath = uriPath baseURI </> encodePageName name <.> "html"
       }
 
 
 mkPageFragmentURI :: URI -> PageName -> String -> URI
 mkPageFragmentURI baseURI name fragment
     = baseURI {
-        uriPath     = "/" </> uriPath baseURI </> encodePageName name <.> "html"
+        uriPath     = uriPath baseURI </> encodePageName name <.> "html"
       , uriFragment = ('#' : encodeFragment fragment)
       }
 
@@ -185,7 +186,7 @@ mkAuxiliaryURI baseURI basePath name
 mkFeedURI :: URI -> PageName -> URI
 mkFeedURI baseURI name
     = baseURI {
-        uriPath = "/" </> uriPath baseURI </> encodePageName name <.> "rdf"
+        uriPath = uriPath baseURI </> encodePageName name <.> "rdf"
       }
 
 
diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index af90bfa..e4456e8 100644
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -21,7 +21,7 @@ import           Rakka.SystemConfig
 import           Rakka.Utils
 import           Rakka.Wiki.Engine
 import           System.FilePath
-import           Text.HyperEstraier
+import           Text.HyperEstraier hiding (getText)
 import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.XmlNodeSet
@@ -41,8 +41,12 @@ resSearch env
       }
 
 
-defaultResultsPerPage :: Int
-defaultResultsPerPage = 20
+resultsPerSection :: Int
+resultsPerSection = 10
+
+
+maxSectionWindowSize :: Int
+maxSectionWindowSize = 10
 
 
 {-
@@ -65,7 +69,7 @@ handleSearch env
          let query = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
              from  = fromMaybe 0
                      $ fmap read $ lookup "from" params
-             to    = fromMaybe defaultResultsPerPage
+             to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ lookup "to"   params
 
          cond   <- liftIO $ mkCond query from to
@@ -186,29 +190,32 @@ searchResultToXHTML env
                                    )
                                 += ( getXPathTreesInDoc "/searchResult/page"
                                      >>>
-                                     eelem "div"
-                                     += sattr "class" "searchResult"
-                                     += ( eelem "a"
-                                          += attr "href" ( getAttrValue "name"
-                                                           >>>
-                                                           arr (\ x -> uriToString id (mkPageURI baseURI x) "")
-                                                           >>>
-                                                           mkText
-                                                         )
-                                          += (getAttrValue "name" >>> mkText)
-                                        )
-                                     += ( eelem "p"
-                                          += ( getChildren
-                                               >>>
-                                               choiceA [ isText             :-> this
-                                                       , hasName "boundary" :-> txt " ... "
-                                                       , hasName "hit"      :-> ( eelem "span"
-                                                                                  += sattr "class" "highlighted"
-                                                                                  += getChildren
-                                                                                )
-                                                       ]
-                                             )
-                                        )
+                                     formatItem baseURI
+                                   )
+                                += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
+                                         >>>
+                                         getText
+                                       )
+                                       &&&
+                                       ( getXPathTreesInDoc "/searchResult/@from/text()"
+                                         >>>
+                                         getText
+                                         >>>
+                                         arr ((`div` resultsPerSection) . read)
+                                       )
+                                       &&&
+                                       ( getXPathTreesInDoc "/searchResult/@total/text()"
+                                         >>>
+                                         getText
+                                         >>>
+                                         arr ((+ 1) . (`div` resultsPerSection) . read)
+                                       )
+                                     )
+                                     >>>
+                                     ( ((> 1) . snd . snd)
+                                       `guardsP`
+                                       formatPager baseURI
+                                     )
                                    )
                               )
                          )
@@ -233,6 +240,113 @@ searchResultToXHTML env
                  >>>
                  uniqueNamespacesFromDeclAndQNames
                ) ) -<< tree
+    where
+      formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
+      formatItem baseURI
+          = ( eelem "div"
+              += sattr "class" "searchResult"
+              += ( eelem "a"
+                   += attr "href" ( getAttrValue "name"
+                                    >>>
+                                    arr (\ x -> uriToString id (mkPageURI baseURI x) "")
+                                    >>>
+                                    mkText
+                                  )
+                   += (getAttrValue "name" >>> mkText)
+                 )
+              += ( eelem "p"
+                   += ( getChildren
+                        >>>
+                        choiceA [ isText             :-> this
+                                , hasName "boundary" :-> txt " ... "
+                                , hasName "hit"      :-> ( eelem "span"
+                                                           += sattr "class" "highlighted"
+                                                           += getChildren
+                                                         )
+                                ]
+                      )
+                 )
+            )
+
+      formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
+      formatPager baseURI
+          = ( eelem "div"
+              += sattr "class" "pager"
+              += txt "Page."
+              += ( ( arr fst
+                     &&&
+                     arr (fst . snd)
+                     &&&
+                     ( arr snd
+                       >>>
+                       mkSectionWindow
+                     )
+                   )
+                   >>>
+                   proc (query, (currentSection, section))
+                       -> if currentSection == section then
+                              ( txt " "
+                                <+> 
+                                eelem "span"
+                                += sattr "class" "currentSection"
+                                += (arr show >>> mkText)
+                              ) -< section
+                          else
+                              ( txt " "
+                                <+>
+                                eelem "a"
+                                += attr "href" ( mkSectionURI baseURI
+                                                 >>>
+                                                 uriToText
+                                               )
+                                += (arr (show . snd) >>> mkText)
+                              ) -< (query, section)
+                 )
+            )
+
+      mkSectionWindow :: ArrowList a => a (Int, Int) Int
+      mkSectionWindow 
+          = proc (currentSection, totalSections)
+          -> let windowWidth  = min maxSectionWindowSize totalSections
+                 windowBegin  = currentSection - (windowWidth `div` 2)
+                 (begin, end) = if windowBegin < 0 then
+                                    -- 左に溢れた
+                                    (0, windowWidth - 1)
+                                else
+                                    if windowBegin + windowWidth >= totalSections then
+                                        -- 右に溢れた
+                                        (totalSections - windowWidth, totalSections - 1)
+                                    else
+                                        -- どちらにも溢れない
+                                        (windowBegin, windowBegin + windowWidth - 1)
+             in
+               arrL id -< [begin .. end]
+                       
+
+      mkSectionURI :: Arrow a => URI -> a (String, Int) URI
+      mkSectionURI baseURI
+          = arr $ \ (query, section)
+          -> baseURI {
+               uriPath  = uriPath baseURI </> "search"
+             , uriQuery = '?' : mkQueryString [ ("q"   , query)
+                                              , ("from", show $ section * resultsPerSection)
+                                              , ("to"  , show $ (section + 1) * resultsPerSection - 1)
+                                              ]
+             }
+
+      uriToText :: ArrowXml a => a URI XmlTree
+      uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+
+      mkQueryString :: [(String, String)] -> String
+      mkQueryString []            = ""
+      mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
+                                    if xs == [] then
+                                        ""
+                                    else
+                                        ';' : mkQueryString(xs)
+
+      encode :: String -> String
+      encode = escapeURIString isSafeChar . UTF8.encodeString
 
 
 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
diff --git a/defaultPages/StyleSheet/Default.xml b/defaultPages/StyleSheet/Default.xml
index 74a17db..cdcc83a 100644
--- a/defaultPages/StyleSheet/Default.xml
+++ b/defaultPages/StyleSheet/Default.xml
@@ -208,6 +208,20 @@ table.pageEditor {
     margin-bottom: 1.5em;
 }
 
+.pager {
+    width: 20em;
+
+    margin-left: auto;
+    margin-right: auto;
+
+    padding: 10px;
+}
+
+.pager a,
+.pager .currentSection {
+    padding: 4px;
+}
+
 /* color and text *************************************************************/
 * {
     font-family: sans-serif;
@@ -421,6 +435,29 @@ input[type="button"][disabled]:active {
     background-color: #ffefd5;
 }
 
+.pager {
+    text-align: center;
+
+    background-color: #f5f5f5;
+
+    border-color: #cccccc;
+    border-width: 1px;
+    border-style: dotted;
+}
+.pager .currentSection,
+.pager a {
+    border-style: solid;
+    border-width: 1px;
+}
+.pager .currentSection {
+    background-color: white;
+    border-color: #cccccc white white #cccccc;
+}
+.pager a {
+    background-color: #e8e8e8;
+    border-color: white #cccccc #cccccc white;
+}
+
 /* float **********************************************************************/
 h1, h2, h3, h4, h5, h6 {
     clear: both;