X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;h=6f72195b41c0ffb172c5ee499242381c1805da7f;hb=9d86882fe1630c844e11cf2cf760110c04ea10d4;hp=20f51c6540931d79ae3c1cae1e1059d5f331a79d;hpb=485a088a55dfebf9687a5a96fda6f083bdd9723f;p=Rakka.git

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index 20f51c6..6f72195 100644
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -13,6 +13,7 @@ import           Control.Monad.Trans
 import           Data.Maybe
 import           Data.Time
 import           Network.HTTP.Lucu
+import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.URI hiding (query, fragment)
 import           Rakka.Environment
 import           Rakka.Page
@@ -69,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
@@ -84,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)
@@ -95,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
@@ -207,6 +216,11 @@ searchResultToXHTML env
                                          getText
                                        )
                                        &&&
+                                       maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+                                                >>>
+                                                getText
+                                              )
+                                       &&&
                                        ( getXPathTreesInDoc "/searchResult/@from/text()"
                                          >>>
                                          getText
@@ -218,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
                                      )
@@ -251,7 +265,7 @@ searchResultToXHTML env
                  uniqueNamespacesFromDeclAndQNames
                ) ) -<< tree
     where
-      formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
+      formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
       formatItem baseURI
           = ( eelem "div"
               += sattr "class" "searchResult"
@@ -264,6 +278,19 @@ searchResultToXHTML env
                                   )
                    += (getAttrValue "name" >>> mkText)
                  )
+              += ( eelem "div"
+                   += sattr "class" "date"
+                   += ( getAttrValue "lastModified"
+                        >>>
+                        arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+                        >>>
+                        arrIO utcToLocalZonedTime
+                        >>>
+                        arr formatRFC1123DateTime
+                        >>>
+                        mkText
+                      )
+                 )
               += ( eelem "p"
                    += ( getChildren
                         >>>
@@ -278,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"
@@ -287,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 " "
                                 <+> 
@@ -309,8 +338,8 @@ searchResultToXHTML env
                                                  >>>
                                                  uriToText
                                                )
-                                += (arr (show . snd) >>> mkText)
-                              ) -< (query, section)
+                                += (arr (show . snd . snd) >>> mkText)
+                              ) -< (query, (order, section))
                  )
             )
 
@@ -333,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