module Rakka.Resource.Search ( resSearch ) where 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 import Rakka.Page import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils import Rakka.Wiki.Engine import System.FilePath import Text.HyperEstraier hiding (getText) import Text.XML.HXT.Arrow import Text.XML.HXT.XPath resSearch :: Environment -> ResourceDef resSearch env = ResourceDef { resUsesNativeThread = False , resIsGreedy = False , resGet = Just $ handleSearch env , resHead = Nothing , resPost = Nothing , resPut = Nothing , resDelete = Nothing } resultsPerSection :: Int resultsPerSection = 10 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 {- aaa foo bbb ... -} handleSearch :: Environment -> Resource () handleSearch env = do params <- getQueryForm let query = fromMaybe "" $ findQueryParam "q" params order = findQueryParam "order" params from = fromMaybe 0 $ fmap read $ findQueryParam "from" params to = fromMaybe (from + resultsPerSection) $ fmap read $ findQueryParam "to" params cond <- liftIO $ mkCond query order from to result <- searchPages (envStorage env) cond let to' = min (from + length (srPages result)) to 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) += ( constL (srPages result) >>> mkPageElem ) ) ) -< () returnA -< outputXmlPage' tree (searchResultToXHTML env) where 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 + 1) return cond mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree mkPageElem = ( eelem "page" += attr "name" (arr hpPageName >>> mkText) += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) >>> arr W3C.format >>> mkText ) += ( arrL hpSnippet >>> mkSnippetTree ) ) mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree mkSnippetTree = proc fragment -> case fragment of 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 -> 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) -< "PageTitle" leftSideBar <- listA (readSubPage env) -< "SideBar/Left" rightSideBar <- listA (readSubPage env) -< "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 ) &&& 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 ) ) ) ) += ( 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 . W3C.parse) >>> arrIO utcToLocalZonedTime >>> arr RFC1123.format >>> 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 PageName XmlTree readSubPage env = proc (subPageName) -> do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage) returnA -< subXHTML