X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;h=6624e9e8baeafcd2f44c9a2d57c4c777be7216f2;hb=f4a4c275bf0afab9f4ed04158866830e20b93cae;hp=8271640847fb3a8df9ee1f8b8cfbd3dba0faedba;hpb=e751af5e3d23d7757f363bf4e86f9d732d90be7f;p=Rakka.git diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index 8271640..6624e9e 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -3,17 +3,31 @@ 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 import Rakka.Resource import Rakka.Storage -import Text.HyperEstraier +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 @@ -30,13 +44,21 @@ resSearch env } +resultsPerSection :: Int +resultsPerSection = 10 + + +maxSectionWindowSize :: Int +maxSectionWindowSize = 10 + + {- - + aaa foo bbb @@ -47,23 +69,26 @@ handleSearch :: Environment -> Resource () handleSearch env = do params <- getQueryForm - let query = fromMaybe "" $ lookup "q" params - from = read $ fromMaybe "0" $ lookup "from" params - to = read $ fromMaybe "20" $ lookup "to" params + let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params + from = fromMaybe 0 + $ fmap read $ lookup "from" params + to = fromMaybe (from + resultsPerSection) + $ fmap read $ lookup "to" params cond <- liftIO $ mkCond query from to result <- searchPages (envStorage env) cond - let to' = min (from + length result) to + 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 += sattr "from" (show from) += sattr "to" (show to') - += sattr "total" (show $ length result) - += ( constL result + += sattr "total" (show $ srTotal result) + += ( constL (srPages result) >>> mkPageElem ) @@ -79,24 +104,281 @@ handleSearch env setMax cond (to - from) return cond - mkPageElem :: ArrowXml a => a SearchResult XmlTree + mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree mkPageElem = ( eelem "page" - += attr "name" (arr srPageName >>> mkText) - += ( arrL srSnippet + += 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 - 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 searchResultToXHTML env = proc tree - -> this -< tree + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf 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") + + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/searchResult/@query/text()" + ) + += ( constL cssHref + >>> + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id >>> mkText) + ) + += ( constL scriptSrc + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr id >>> mkText) + ) + += ( eelem "script" + += sattr "type" "text/javascript" + += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") + += txt "Rakka.isSpecialPage=true;" + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += ( eelem "h1" + += txt "Search Result" + ) + += ( eelem "div" + += sattr "class" "searchStat" + += txt "Search result for " + += ( eelem "span" + += sattr "class" "queryString" + += getXPathTreesInDoc "/searchResult/@query/text()" + ) + += txt ": found " + += getXPathTreesInDoc "/searchResult/@total/text()" + += txt " pages." + ) + += ( getXPathTreesInDoc "/searchResult/page" + >>> + 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 + ) + ) + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL leftSideBar + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL rightSideBar + ) + ) + ) + >>> + 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, (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) => + Environment + -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree +readSubPage env + = proc (mainPageName, mainPage, subPageName) -> + do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) + -< (mainPageName, mainPage, subPage) + returnA -< subXHTML