X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;h=0543684249401256f00cec51f809e0f7e2dacb09;hb=d717326c5f603dd140a0b5ee27b412e5e09685cd;hp=20f51c6540931d79ae3c1cae1e1059d5f331a79d;hpb=485a088a55dfebf9687a5a96fda6f083bdd9723f;p=Rakka.git diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index 20f51c6..0543684 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -3,15 +3,13 @@ module Rakka.Resource.Search ) where -import qualified Codec.Binary.UTF8.String as UTF8 -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList -import Control.Arrow.ArrowTree +import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Monad.Trans +import Data.List import Data.Maybe import Data.Time +import qualified Data.Time.RFC1123 as RFC1123 +import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu import Network.URI hiding (query, fragment) import Rakka.Environment @@ -20,14 +18,11 @@ import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils -import Rakka.W3CDateTime import Rakka.Wiki.Engine import System.FilePath import Text.HyperEstraier hiding (getText) -import Text.XML.HXT.Arrow.Namespace -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlNodeSet -import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.Arrow +import Text.XML.HXT.XPath resSearch :: Environment -> ResourceDef @@ -51,6 +46,11 @@ maxSectionWindowSize :: Int maxSectionWindowSize = 10 +findQueryParam :: String -> [FormData] -> Maybe String +findQueryParam name qps + = do fd <- find (\ qp -> fdName qp == name) qps + return $ UTF8.toString $ fdContent fd + {- Resource () handleSearch env = do params <- getQueryForm - let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params + let query = fromMaybe "" $ findQueryParam "q" params + order = findQueryParam "order" params from = fromMaybe 0 - $ fmap read $ lookup "from" params + $ fmap read $ findQueryParam "from" params to = fromMaybe (from + resultsPerSection) - $ fmap read $ lookup "to" params + $ fmap read $ findQueryParam "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 +85,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 +100,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 @@ -108,7 +116,7 @@ handleSearch env += attr "name" (arr hpPageName >>> mkText) += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) >>> - arr formatW3CDateTime + arr W3C.format >>> mkText ) @@ -139,9 +147,9 @@ searchResultToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< "PageTitle" + leftSideBar <- listA (readSubPage env) -< "SideBar/Left" + rightSideBar <- listA (readSubPage env) -< "SideBar/Right" ( eelem "/" += ( eelem "html" @@ -207,6 +215,11 @@ searchResultToXHTML env getText ) &&& + maybeA ( getXPathTreesInDoc "/searchResult/@order/text()" + >>> + getText + ) + &&& ( getXPathTreesInDoc "/searchResult/@from/text()" >>> getText @@ -218,11 +231,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 +264,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 +277,19 @@ searchResultToXHTML env ) += (getAttrValue "name" >>> mkText) ) + += ( eelem "div" + += sattr "class" "date" + += ( getAttrValue "lastModified" + >>> + arr (zonedTimeToUTC . fromJust . W3C.parse) + >>> + arrIO utcToLocalZonedTime + >>> + arr RFC1123.format + >>> + mkText + ) + ) += ( eelem "p" += ( getChildren >>> @@ -278,7 +304,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 +313,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 +337,8 @@ searchResultToXHTML env >>> uriToText ) - += (arr (show . snd) >>> mkText) - ) -< (query, section) + += (arr (show . snd . snd) >>> mkText) + ) -< (query, (order, section)) ) ) @@ -333,38 +361,31 @@ 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 - +-- FIXME: localize readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree + Environment -> a PageName XmlTree readSubPage env - = proc (mainPageName, mainPage, subPageName) -> + = proc (subPageName) -> do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) - subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) - -< (mainPageName, mainPage, subPage) + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage) returnA -< subXHTML