+{-# 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 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.HTTP.Lucu.RFC1123DateTime
import Network.URI hiding (query, fragment)
+import Prelude.Unicode
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
-import Text.XML.HXT.Arrow
-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
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
{-
<searchResult query="foo bar baz"
...
</searchResult>
-}
-handleSearch :: Environment -> Resource ()
+handleSearch ∷ Environment → Resource ()
handleSearch env
- = do params <- getQueryForm
+ = do params ← getQueryForm
let query = fromMaybe "" $ findQueryParam "q" params
order = findQueryParam "order" params
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 formatW3CDateTime
- >>>
+ ⋙
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 . parseW3CDateTime)
- >>>
+ ⋙
arrIO utcToLocalZonedTime
- >>>
- arr formatRFC1123DateTime
- >>>
+ ⋙
+ arr RFC1123.format
+ ⋙
mkText
)
)
+= ( eelem "p"
+= ( getChildren
- >>>
+ ⋙
choiceA [ isText :-> this
, hasName "boundary" :-> txt " ... "
, hasName "hit" :-> ( eelem "span"
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))
)
)
-- どちらにも溢れない
(windowBegin, windowBegin + windowWidth - 1)
in
- arrL id -< [begin .. end]
+ arrL id ⤙ [begin .. end]
mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
}
uriToText :: ArrowXml a => a URI XmlTree
- uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+ uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText
-- FIXME: localize
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
projects / Rakka.git / blobdiff