X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FSearch.hs;fp=Rakka%2FResource%2FSearch.hs;h=2d076e890556db5da7e04bb29e5aa9f730b92e56;hp=eb4acf253d11c4d0535bed1c25082fc350e58fec;hb=45bce2c29948649f74ada71f2fa851bdb812e96c;hpb=9932fbe6504e8b812703291e2497a5f010880d3b diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index eb4acf2..2d076e8 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -1,15 +1,33 @@ +{-# LANGUAGE + Arrows + , OverloadedStrings + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Resource.Search ( resSearch ) where +import Control.Applicative +import Control.Arrow +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree +import Control.Arrow.Unicode +import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Monad.Trans -import Data.List +import qualified Data.ByteString.Char8 as C8 import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T 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 Prelude.Unicode import Rakka.Environment import Rakka.Page import Rakka.Resource @@ -19,8 +37,10 @@ import Rakka.Utils import Rakka.Wiki.Engine import System.FilePath import Text.HyperEstraier hiding (getText) -import Text.XML.HXT.XPath - +import Text.XML.HXT.Arrow.Namespace +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.XPath resSearch :: Environment -> ResourceDef resSearch env @@ -42,11 +62,9 @@ resultsPerSection = 10 maxSectionWindowSize :: Int maxSectionWindowSize = 10 - -findQueryParam :: String -> [FormData] -> Maybe String +findQueryParam ∷ String → [(String, FormData)] → Maybe String findQueryParam name qps - = do fd <- find (\ qp -> fdName qp == name) qps - return $ UTF8.toString $ fdContent fd + = UTF8.toString ∘ fdContent <$> lookup name qps {- -} -handleSearch :: Environment -> Resource () +handleSearch ∷ Environment → Resource () handleSearch env - = do params <- getQueryForm + = do params ← getQueryForm let query = fromMaybe "" $ findQueryParam "q" params order = findQueryParam "order" params @@ -72,224 +90,219 @@ handleSearch env to = fromMaybe (from + resultsPerSection) $ fmap read $ findQueryParam "to" params - cond <- liftIO $ mkCond query order from to - result <- searchPages (envStorage env) cond + cond ← liftIO $ mkCond (T.pack query) (T.pack <$> order) from to + result ← searchPages (envStorage env) cond let to' = min (from + length (srPages result)) to - BaseURI baseURI <- getSysConf (envSysConf env) + 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) + → 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 ∷ Text → Maybe Text → Int → Int → IO Condition mkCond query order from to - = do cond <- newCondition + = 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 + Just o → setOrder cond o + Nothing → return () + setSkip cond from + setMax cond (to - from + 1) + pure cond - mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree + mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree mkPageElem = ( eelem "page" - += attr "name" (arr hpPageName >>> mkText) - += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) - >>> + += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText) + += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod) + ⋙ arr W3C.format - >>> + ⋙ mkText ) += ( arrL hpSnippet - >>> + ⋙ mkSnippetTree ) ) - mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree + mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree mkSnippetTree = proc fragment - -> case fragment of - Boundary -> eelem "boundary" -< () - NormalText t -> mkText -< t - HighlightedWord w -> ( eelem "hit" - += mkText - ) -< w - + → case fragment of + Boundary → eelem "boundary" ⤙ () + NormalText t → mkText ⤙ T.unpack t + HighlightedWord w → ( eelem "hit" + += mkText + ) ⤙ T.unpack w -searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +searchResultToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → 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) -< () + → 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" }) ""] + 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" + 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) + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt (T.unpack 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()" ) - ) - >>> - ( ((> 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 + += 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 ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ URI + → XmlTree ⇝ XmlTree formatItem baseURI = ( eelem "div" += sattr "class" "searchResult" += ( eelem "a" += attr "href" ( getAttrValue "name" - >>> - arr (\ x -> uriToString id (mkPageURI baseURI x) "") - >>> + ⋙ + arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "") + ⋙ mkText ) - += (getAttrValue "name" >>> 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" @@ -313,29 +326,29 @@ searchResultToXHTML env 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 + += (arr show ⋙ mkText) + ) ⤙ section else ( txt " " <+> eelem "a" += attr "href" ( mkSectionURI baseURI - >>> + ⋙ uriToText ) - += (arr (show . snd . snd) >>> mkText) - ) -< (query, (order, section)) + += (arr (show . snd . snd) ⋙ mkText) + ) ⤙ (query, (order, section)) ) ) @@ -355,7 +368,7 @@ searchResultToXHTML env -- どちらにも溢れない (windowBegin, windowBegin + windowWidth - 1) in - arrL id -< [begin .. end] + arrL id ⤙ [begin .. end] mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI @@ -363,19 +376,19 @@ searchResultToXHTML env = 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 -> [] - ) + , uriQuery = '?' : C8.unpack (mkQueryString ( [ ("q" , T.pack query) + , ("from", T.pack ∘ show $ section ⋅ resultsPerSection ) + , ("to" , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1) + ] + ++ + case order of + Just o -> [("order", T.pack o)] + Nothing -> [] + )) } uriToText :: ArrowXml a => a URI XmlTree - uriToText = arr (\ uri -> uriToString id uri "") >>> mkText + uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText -- FIXME: localize @@ -383,6 +396,6 @@ 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 + do subPage ← getPageA (envStorage env) ⋙ arr fromJust ⋙ xmlizePage ⤙ (subPageName, Nothing) + subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) ⤙ (Nothing, Nothing, subPage) + returnA ⤙ subXHTML