X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;h=7318e30b34845b9bb01aa4ef65fd8b38cd86976d;hb=0b97160b4d55eca16f3c56b47a908997fc458284;hp=af90bfa3844395a6d70392767a07c7fe130c36c1;hpb=b4c0033f297c28d95ad9298b489126331224bc42;p=Rakka.git diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index af90bfa..7318e30 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -4,14 +4,11 @@ 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 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 @@ -19,12 +16,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 -import Text.XML.HXT.Arrow.Namespace -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlNodeSet +import Text.HyperEstraier hiding (getText) +import Text.XML.HXT.Arrow import Text.XML.HXT.DOM.TypeDefs @@ -41,8 +37,12 @@ resSearch env } -defaultResultsPerPage :: Int -defaultResultsPerPage = 20 +resultsPerSection :: Int +resultsPerSection = 10 + + +maxSectionWindowSize :: Int +maxSectionWindowSize = 10 {- @@ -51,7 +51,7 @@ defaultResultsPerPage = 20 to="5" total="5"> - + aaa foo bbb @@ -63,20 +63,26 @@ 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 defaultResultsPerPage + 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 - runIdempotentA $ proc () + BaseURI baseURI <- getSysConf (envSysConf env) + runIdempotentA baseURI $ proc () -> 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) @@ -88,30 +94,40 @@ 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 :: ArrowXml a => a HitPage XmlTree + mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree mkPageElem = ( eelem "page" += attr "name" (arr hpPageName >>> mkText) + += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) + >>> + arr formatW3CDateTime + >>> + mkText + ) += ( arrL hpSnippet >>> mkSnippetTree ) ) - mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree + mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree mkSnippetTree = proc fragment -> case fragment of - Boundary -> eelem "boundary" - NormalText t -> txt t - HighlightedWord w -> eelem "hit" += txt w - -<< () + Boundary -> eelem "boundary" -< () + NormalText t -> mkText -< t + HighlightedWord w -> ( eelem "hit" + += mkText + ) -< w searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree @@ -125,9 +141,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" @@ -186,29 +202,37 @@ 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 + ) + &&& + maybeA ( getXPathTreesInDoc "/searchResult/@order/text()" + >>> + getText + ) + &&& + ( getXPathTreesInDoc "/searchResult/@from/text()" + >>> + getText + >>> + arr ((`div` resultsPerSection) . read) + ) + &&& + ( getXPathTreesInDoc "/searchResult/@total/text()" + >>> + getText + >>> + arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read) + ) + ) + >>> + ( ((> 1) . snd . snd . snd) + `guardsP` + formatPager baseURI + ) ) ) ) @@ -233,14 +257,129 @@ searchResultToXHTML env >>> uniqueNamespacesFromDeclAndQNames ) ) -<< tree + where + formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO 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 "div" + += sattr "class" "date" + += ( getAttrValue "lastModified" + >>> + arr (zonedTimeToUTC . fromJust . parseW3CDateTime) + >>> + arrIO utcToLocalZonedTime + >>> + arr formatRFC1123DateTime + >>> + 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, (Maybe String, (Int, Int))) XmlTree + formatPager baseURI + = ( eelem "div" + += sattr "class" "pager" + += txt "Page." + += ( ( arr fst + &&& + arr (fst . snd) + &&& + arr (fst . snd . snd) + &&& + ( arr (snd . snd) + >>> + mkSectionWindow + ) + ) + >>> + proc (query, (order, (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 . snd) >>> mkText) + ) -< (query, (order, 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, (Maybe String, Int)) URI + mkSectionURI baseURI + = arr $ \ (query, (order, section)) + -> baseURI { + 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 +-- 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