Rakka/Resource/Search.hs

   1 module Rakka.Resource.Search
   2     ( resSearch
   3     )
   4     where
   5
   6 import qualified Codec.Binary.UTF8.String as UTF8
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowIO
   9 import           Control.Arrow.ArrowIf
  10 import           Control.Arrow.ArrowList
  11 import           Control.Arrow.ArrowTree
  12 import           Control.Monad.Trans
  13 import           Data.Maybe
  14 import           Network.HTTP.Lucu
  15 import           Network.URI hiding (query, fragment)
  16 import           Rakka.Environment
  17 import           Rakka.Page
  18 import           Rakka.Resource
  19 import           Rakka.Storage
  20 import           Rakka.SystemConfig
  21 import           Rakka.Utils
  22 import           Rakka.Wiki.Engine
  23 import           System.FilePath
  24 import           Text.HyperEstraier hiding (getText)
  25 import           Text.XML.HXT.Arrow.Namespace
  26 import           Text.XML.HXT.Arrow.XmlArrow
  27 import           Text.XML.HXT.Arrow.XmlNodeSet
  28 import           Text.XML.HXT.DOM.TypeDefs
  29
  30
  31 resSearch :: Environment -> ResourceDef
  32 resSearch env
  33     = ResourceDef {
  34         resUsesNativeThread = False
  35       , resIsGreedy         = False
  36       , resGet              = Just $ handleSearch env
  37       , resHead             = Nothing
  38       , resPost             = Nothing
  39       , resPut              = Nothing
  40       , resDelete           = Nothing
  41       }
  42
  43
  44 resultsPerSection :: Int
  45 resultsPerSection = 10
  46
  47
  48 maxSectionWindowSize :: Int
  49 maxSectionWindowSize = 10
  50
  51
  52 {-
  53   <searchResult query="foo bar baz"
  54                 from="0"
  55                 to="5"
  56                 total="5">
  57
  58     <page name="Page/1">
  59       aaa <hit>foo</hit> bbb
  60     </page>
  61
  62     ...
  63   </searchResult>
  64 -}
  65 handleSearch :: Environment -> Resource ()
  66 handleSearch env
  67     = do params <- getQueryForm
  68
  69          let query = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
  70              from  = fromMaybe 0
  71                      $ fmap read $ lookup "from" params
  72              to    = fromMaybe (from + resultsPerSection)
  73                      $ fmap read $ lookup "to"   params
  74
  75          cond   <- liftIO $ mkCond query from to
  76          result <- searchPages (envStorage env) cond
  77
  78          let to' = min (from + length (srPages result)) to
  79
  80          runIdempotentA $ proc ()
  81              -> do tree <- ( eelem "/"
  82                              += ( eelem "searchResult"
  83                                   += sattr "query" query
  84                                   += sattr "from"  (show from)
  85                                   += sattr "to"    (show to')
  86                                   += sattr "total" (show $ srTotal result)
  87                                   += ( constL (srPages result)
  88                                        >>>
  89                                        mkPageElem
  90                                      )
  91                                 )
  92                            ) -< ()
  93                    returnA -< outputXmlPage' tree (searchResultToXHTML env)
  94     where
  95       mkCond :: String -> Int -> Int -> IO Condition
  96       mkCond query from to
  97           = do cond <- newCondition
  98                setPhrase cond query
  99                setSkip   cond from
 100                setMax    cond (to - from)
 101                return cond
 102
 103       mkPageElem :: ArrowXml a => a HitPage XmlTree
 104       mkPageElem = ( eelem "page"
 105                      += attr "name" (arr hpPageName >>> mkText)
 106                      += ( arrL hpSnippet
 107                           >>>
 108                           mkSnippetTree
 109                         )
 110                    )
 111
 112       mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
 113       mkSnippetTree = proc fragment
 114                     -> case fragment of
 115                          Boundary          -> eelem "boundary"
 116                          NormalText      t -> txt t
 117                          HighlightedWord w -> eelem "hit" += txt w
 118                          -<< ()
 119
 120
 121 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 122 searchResultToXHTML env
 123     = proc tree
 124     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 125           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 126           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 127           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 128
 129           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 130               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 131
 132           pageTitle    <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
 133           leftSideBar  <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
 134           rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
 135
 136           ( eelem "/"
 137             += ( eelem "html"
 138                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 139                  += ( eelem "head"
 140                       += ( eelem "title"
 141                            += txt siteName
 142                            += txt " - "
 143                            += getXPathTreesInDoc "/searchResult/@query/text()"
 144                          )
 145                       += ( constL cssHref
 146                            >>>
 147                            eelem "link"
 148                            += sattr "rel"  "stylesheet"
 149                            += sattr "type" "text/css"
 150                            += attr "href" (arr id >>> mkText)
 151                          )
 152                       += ( constL scriptSrc
 153                            >>>
 154                            eelem "script"
 155                            += sattr "type" "text/javascript"
 156                            += attr "src" (arr id >>> mkText)
 157                          )
 158                       += ( eelem "script"
 159                            += sattr "type" "text/javascript"
 160                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 161                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 162                            += txt  "Rakka.isSpecialPage=true;"
 163                          )
 164                     )
 165                  += ( eelem "body"
 166                       += ( eelem "div"
 167                            += sattr "class" "header"
 168                          )
 169                       += ( eelem "div"
 170                            += sattr "class" "center"
 171                            += ( eelem "div"
 172                                 += sattr "class" "title"
 173                                 += constL pageTitle
 174                               )
 175                            += ( eelem "div"
 176                                 += sattr "class" "body"
 177                                 += ( eelem "h1"
 178                                      += txt "Search Result"
 179                                    )
 180                                 += ( eelem "div"
 181                                      += sattr "class" "searchStat"
 182                                      += txt "Search result for "
 183                                      += ( eelem "span"
 184                                           += sattr "class" "queryString"
 185                                           += getXPathTreesInDoc "/searchResult/@query/text()"
 186                                         )
 187                                      += txt ": found "
 188                                      += getXPathTreesInDoc "/searchResult/@total/text()"
 189                                      += txt " pages."
 190                                    )
 191                                 += ( getXPathTreesInDoc "/searchResult/page"
 192                                      >>>
 193                                      formatItem baseURI
 194                                    )
 195                                 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
 196                                          >>>
 197                                          getText
 198                                        )
 199                                        &&&
 200                                        ( getXPathTreesInDoc "/searchResult/@from/text()"
 201                                          >>>
 202                                          getText
 203                                          >>>
 204                                          arr ((`div` resultsPerSection) . read)
 205                                        )
 206                                        &&&
 207                                        ( getXPathTreesInDoc "/searchResult/@total/text()"
 208                                          >>>
 209                                          getText
 210                                          >>>
 211                                          arr ((+ 1) . (`div` resultsPerSection) . read)
 212                                        )
 213                                      )
 214                                      >>>
 215                                      ( ((> 1) . snd . snd)
 216                                        `guardsP`
 217                                        formatPager baseURI
 218                                      )
 219                                    )
 220                               )
 221                          )
 222                       += ( eelem "div"
 223                            += sattr "class" "footer"
 224                          )
 225                       += ( eelem "div"
 226                            += sattr "class" "left sideBar"
 227                            += ( eelem "div"
 228                                 += sattr "class" "content"
 229                                 += constL leftSideBar
 230                               )
 231                          )
 232                       += ( eelem "div"
 233                            += sattr "class" "right sideBar"
 234                            += ( eelem "div"
 235                                 += sattr "class" "content"
 236                                 += constL rightSideBar
 237                               )
 238                          )
 239                     )
 240                  >>>
 241                  uniqueNamespacesFromDeclAndQNames
 242                ) ) -<< tree
 243     where
 244       formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
 245       formatItem baseURI
 246           = ( eelem "div"
 247               += sattr "class" "searchResult"
 248               += ( eelem "a"
 249                    += attr "href" ( getAttrValue "name"
 250                                     >>>
 251                                     arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 252                                     >>>
 253                                     mkText
 254                                   )
 255                    += (getAttrValue "name" >>> mkText)
 256                  )
 257               += ( eelem "p"
 258                    += ( getChildren
 259                         >>>
 260                         choiceA [ isText             :-> this
 261                                 , hasName "boundary" :-> txt " ... "
 262                                 , hasName "hit"      :-> ( eelem "span"
 263                                                            += sattr "class" "highlighted"
 264                                                            += getChildren
 265                                                          )
 266                                 ]
 267                       )
 268                  )
 269             )
 270
 271       formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
 272       formatPager baseURI
 273           = ( eelem "div"
 274               += sattr "class" "pager"
 275               += txt "Page."
 276               += ( ( arr fst
 277                      &&&
 278                      arr (fst . snd)
 279                      &&&
 280                      ( arr snd
 281                        >>>
 282                        mkSectionWindow
 283                      )
 284                    )
 285                    >>>
 286                    proc (query, (currentSection, section))
 287                        -> if currentSection == section then
 288                               ( txt " "
 289                                 <+>
 290                                 eelem "span"
 291                                 += sattr "class" "currentSection"
 292                                 += (arr show >>> mkText)
 293                               ) -< section
 294                           else
 295                               ( txt " "
 296                                 <+>
 297                                 eelem "a"
 298                                 += attr "href" ( mkSectionURI baseURI
 299                                                  >>>
 300                                                  uriToText
 301                                                )
 302                                 += (arr (show . snd) >>> mkText)
 303                               ) -< (query, section)
 304                  )
 305             )
 306
 307       mkSectionWindow :: ArrowList a => a (Int, Int) Int
 308       mkSectionWindow
 309           = proc (currentSection, totalSections)
 310           -> let windowWidth  = min maxSectionWindowSize totalSections
 311                  windowBegin  = currentSection - (windowWidth `div` 2)
 312                  (begin, end) = if windowBegin < 0 then
 313                                     -- 左に溢れた
 314                                     (0, windowWidth - 1)
 315                                 else
 316                                     if windowBegin + windowWidth >= totalSections then
 317                                         -- 右に溢れた
 318                                         (totalSections - windowWidth, totalSections - 1)
 319                                     else
 320                                         -- どちらにも溢れない
 321                                         (windowBegin, windowBegin + windowWidth - 1)
 322              in
 323                arrL id -< [begin .. end]
 324
 325
 326       mkSectionURI :: Arrow a => URI -> a (String, Int) URI
 327       mkSectionURI baseURI
 328           = arr $ \ (query, section)
 329           -> baseURI {
 330                uriPath  = uriPath baseURI </> "search"
 331              , uriQuery = '?' : mkQueryString [ ("q"   , query)
 332                                               , ("from", show $ section * resultsPerSection)
 333                                               , ("to"  , show $ (section + 1) * resultsPerSection - 1)
 334                                               ]
 335              }
 336
 337       uriToText :: ArrowXml a => a URI XmlTree
 338       uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
 339
 340       mkQueryString :: [(String, String)] -> String
 341       mkQueryString []            = ""
 342       mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
 343                                     if xs == [] then
 344                                         ""
 345                                     else
 346                                         ';' : mkQueryString(xs)
 347
 348       encode :: String -> String
 349       encode = escapeURIString isSafeChar . UTF8.encodeString
 350
 351
 352 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 353                Environment
 354             -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
 355 readSubPage env
 356     = proc (mainPageName, mainPage, subPageName) ->
 357       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 358          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 359                      -< (mainPageName, mainPage, subPage)
 360          returnA -< subXHTML