+{-# LANGUAGE
+ Arrows
+ , OverloadedStrings
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Resource.Search
( 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.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.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 Network.HTTP.Lucu
import Network.URI hiding (query, fragment)
+import Prelude.Unicode
import Rakka.Environment
import Rakka.Page
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 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
-
+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
maxSectionWindowSize :: Int
maxSectionWindowSize = 10
+findQueryParam ∷ String → [(String, FormData)] → Maybe String
+findQueryParam name qps
+ = UTF8.toString ∘ fdContent <$> lookup name qps
{-
<searchResult query="foo bar baz"
to="5"
total="5">
- <page name="Page/1">
+ <page name="Page/1" lastModified="2000-01-01T00:00:00">
aaa <hit>foo</hit> bbb
</page>
...
</searchResult>
-}
-handleSearch :: Environment -> Resource ()
+handleSearch ∷ Environment → Resource ()
handleSearch env
- = do params <- getQueryForm
+ = 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
+ $ fmap read $ findQueryParam "from" params
to = fromMaybe (from + resultsPerSection)
- $ fmap read $ lookup "to" params
+ $ fmap read $ findQueryParam "to" params
- cond <- liftIO $ mkCond query 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
- runIdempotentA $ proc ()
- -> do tree <- ( eelem "/"
- += ( eelem "searchResult"
- += sattr "query" query
- += sattr "from" (show from)
- += sattr "to" (show to')
- += sattr "total" (show $ srTotal result)
- += ( constL (srPages result)
- >>>
- mkPageElem
- )
- )
- ) -< ()
- returnA -< outputXmlPage' tree (searchResultToXHTML 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)
where
- mkCond :: String -> Int -> Int -> IO Condition
- mkCond query from to
- = do cond <- newCondition
+ mkCond ∷ Text → Maybe Text → Int → Int → IO Condition
+ mkCond query order from to
+ = do cond ← newCondition
setPhrase cond query
- setSkip cond from
- setMax cond (to - from)
- return cond
+ case order of
+ Just o → setOrder cond o
+ Nothing → return ()
+ setSkip cond from
+ setMax cond (to - from + 1)
+ pure cond
- mkPageElem :: ArrowXml a => a HitPage XmlTree
+ mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree
mkPageElem = ( eelem "page"
- += attr "name" (arr hpPageName >>> mkText)
+ += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
+ += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
+ ⋙
+ arr formatW3CDateTime
+ ⋙
+ mkText
+ )
+= ( arrL hpSnippet
- >>>
+ ⋙
mkSnippetTree
)
)
- mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
+ mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree
mkSnippetTree = proc fragment
- -> case fragment of
- Boundary -> eelem "boundary"
- NormalText t -> txt t
- HighlightedWord w -> eelem "hit" += txt 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) -< (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"
- += 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)
+ ( 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)
- `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) => 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 . parseW3CDateTime)
+ ⋙
+ arrIO utcToLocalZonedTime
+ ⋙
+ arr RFC1123.format
+ ⋙
+ mkText
+ )
)
+= ( eelem "p"
+= ( getChildren
- >>>
+ ⋙
choiceA [ isText :-> this
, hasName "boundary" :-> txt " ... "
, hasName "hit" :-> ( eelem "span"
)
)
- formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
+ formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
formatPager baseURI
= ( eelem "div"
+= sattr "class" "pager"
&&&
arr (fst . snd)
&&&
- ( arr snd
- >>>
+ arr (fst . snd . snd)
+ &&&
+ ( arr (snd . snd)
+ ⋙
mkSectionWindow
)
)
- >>>
- proc (query, (currentSection, section))
+ ⋙
+ 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) >>> mkText)
- ) -< (query, section)
+ += (arr (show . snd . snd) ⋙ mkText)
+ ) ⤙ (query, (order, section))
)
)
-- どちらにも溢れない
(windowBegin, windowBegin + windowWidth - 1)
in
- arrL id -< [begin .. end]
+ arrL id ⤙ [begin .. end]
- mkSectionURI :: Arrow a => URI -> a (String, Int) URI
+ mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
mkSectionURI baseURI
- = arr $ \ (query, section)
+ = arr $ \ (query, (order, section))
-> baseURI {
- uriPath = uriPath baseURI </> "search"
- , uriQuery = '?' : mkQueryString [ ("q" , query)
- , ("from", show $ section * resultsPerSection)
- , ("to" , show $ (section + 1) * resultsPerSection - 1)
- ]
+ 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
-
- 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
+ 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) ->
- do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
- subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
- -< (mainPageName, mainPage, subPage)
- returnA -< subXHTML
+ = 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
projects / Rakka.git / blobdiff