X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;h=e4456e878387ef79e5bd414b1fe7c374bc4c8c7e;hp=af90bfa3844395a6d70392767a07c7fe130c36c1;hb=8d621fced0d1b3f66d38b16cd732fd2342622c5d;hpb=b4c0033f297c28d95ad9298b489126331224bc42

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) =>