List all pages

[Rakka.git] / Rakka / Resource / Search.hs

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index 6624e9e8baeafcd2f44c9a2d57c4c777be7216f2..6f72195b41c0ffb172c5ee499242381c1805da7f 100644 (file)
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -70,12 +70,13 @@ handleSearch env
     = do params <- getQueryForm
 
          let query = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
+             order = fmap UTF8.decodeString (lookup "order" params)
              from  = fromMaybe 0
                      $ fmap read $ lookup "from" params
              to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ lookup "to"   params
 
-         cond   <- liftIO $ mkCond query from to
+         cond   <- liftIO $ mkCond query order from to
          result <- searchPages (envStorage env) cond
 
          let to' = min (from + length (srPages result)) to
@@ -85,6 +86,10 @@ handleSearch env
              -> do tree <- ( eelem "/"
                              += ( eelem "searchResult"
                                   += sattr "query" query
+                                  += ( case order of
+                                         Just o  -> sattr "order" o
+                                         Nothing -> none
+                                     )
                                   += sattr "from"  (show from)
                                   += sattr "to"    (show to')
                                   += sattr "total" (show $ srTotal result)
@@ -96,12 +101,15 @@ handleSearch env
                            ) -< ()
                    returnA -< outputXmlPage' tree (searchResultToXHTML env)
     where
-      mkCond :: String -> Int -> Int -> IO Condition
-      mkCond query from to
+      mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
+      mkCond query order from to
           = do cond <- newCondition
                setPhrase cond query
+               case order of
+                 Just o  -> setOrder cond o
+                 Nothing -> return ()
                setSkip   cond from
-               setMax    cond (to - from)
+               setMax    cond (to - from + 1)
                return cond
 
       mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
@@ -208,6 +216,11 @@ searchResultToXHTML env
                                          getText
                                        )
                                        &&&
+                                       maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+                                                >>>
+                                                getText
+                                              )
+                                       &&&
                                        ( getXPathTreesInDoc "/searchResult/@from/text()"
                                          >>>
                                          getText
@@ -219,11 +232,11 @@ searchResultToXHTML env
                                          >>>
                                          getText
                                          >>>
-                                         arr ((+ 1) . (`div` resultsPerSection) . read)
+                                         arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
                                        )
                                      )
                                      >>>
-                                     ( ((> 1) . snd . snd)
+                                     ( ((> 1) . snd . snd . snd)
                                        `guardsP`
                                        formatPager baseURI
                                      )
@@ -292,7 +305,7 @@ searchResultToXHTML env
                  )
             )
 
-      formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
+      formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
       formatPager baseURI
           = ( eelem "div"
               += sattr "class" "pager"
@@ -301,13 +314,15 @@ searchResultToXHTML env
                      &&&
                      arr (fst . snd)
                      &&&
-                     ( arr snd
+                     arr (fst . snd . snd)
+                     &&&
+                     ( arr (snd . snd)
                        >>>
                        mkSectionWindow
                      )
                    )
                    >>>
-                   proc (query, (currentSection, section))
+                   proc (query, (order, (currentSection, section)))
                        -> if currentSection == section then
                               ( txt " "
                                 <+> 
@@ -323,8 +338,8 @@ searchResultToXHTML env
                                                  >>>
                                                  uriToText
                                                )
-                                += (arr (show . snd) >>> mkText)
-                              ) -< (query, section)
+                                += (arr (show . snd . snd) >>> mkText)
+                              ) -< (query, (order, section))
                  )
             )
 
@@ -347,31 +362,25 @@ searchResultToXHTML env
                arrL id -< [begin .. end]
                        
 
-      mkSectionURI :: Arrow a => URI -> a (String, Int) URI
+      mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
       mkSectionURI baseURI
-          = arr $ \ (query, section)
+          = arr $ \ (query, (order, section))
           -> baseURI {
-               uriPath  = uriPath baseURI </> "search"
-             , uriQuery = '?' : mkQueryString [ ("q"   , query)
-                                              , ("from", show $ section * resultsPerSection)
-                                              , ("to"  , show $ (section + 1) * resultsPerSection - 1)
-                                              ]
+               uriPath  = uriPath baseURI </> "search.html"
+             , uriQuery = '?' : mkQueryString ( [ ("q"   , query)
+                                                , ("from", show $ section * resultsPerSection)
+                                                , ("to"  , show $ (section + 1) * resultsPerSection - 1)
+                                                ]
+                                                ++ 
+                                                case order of
+                                                  Just o  -> [("order", o)]
+                                                  Nothing -> []
+                                              )
              }
 
       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) =>
                Environment