( resSearch
)
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.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.Utils
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.XML.HXT.DOM.TypeDefs
+import Text.HyperEstraier hiding (getText)
+import Text.XML.HXT.XPath
resSearch :: Environment -> ResourceDef
}
-defaultResultsPerPage :: Int
-defaultResultsPerPage = 20
+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
+
{-
<searchResult query="foo bar baz"
from="0"
to="5"
total="5">
- <page name="Page/1">
+ <page name="Page/1" lastModified="2000-01-01T00:00:00">
aaa <hit>foo</hit> bbb
</page>
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
- to = fromMaybe defaultResultsPerPage
- $ fmap read $ lookup "to" params
+ $ fmap read $ findQueryParam "from" params
+ to = fromMaybe (from + resultsPerSection)
+ $ 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
- 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)
) -< ()
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 W3C.format
+ >>>
+ 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
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"
)
+= ( 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
+ )
)
)
)
>>>
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 (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
projects / Rakka.git / blobdiff