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          BaseURI baseURI <- getSysConf (envSysConf env)
  81          runIdempotentA baseURI $ proc ()
  82              -> do tree <- ( eelem "/"
  83                              += ( eelem "searchResult"
  84                                   += sattr "query" query
  85                                   += sattr "from"  (show from)
  86                                   += sattr "to"    (show to')
  87                                   += sattr "total" (show $ srTotal result)
  88                                   += ( constL (srPages result)
  89                                        >>>
  90                                        mkPageElem
  91                                      )
  92                                 )
  93                            ) -< ()
  94                    returnA -< outputXmlPage' tree (searchResultToXHTML env)
  95     where
  96       mkCond :: String -> Int -> Int -> IO Condition
  97       mkCond query from to
  98           = do cond <- newCondition
  99                setPhrase cond query
 100                setSkip   cond from
 101                setMax    cond (to - from)
 102                return cond
 103
 104       mkPageElem :: ArrowXml a => a HitPage XmlTree
 105       mkPageElem = ( eelem "page"
 106                      += attr "name" (arr hpPageName >>> mkText)
 107                      += ( arrL hpSnippet
 108                           >>>
 109                           mkSnippetTree
 110                         )
 111                    )
 112
 113       mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
 114       mkSnippetTree = proc fragment
 115                     -> case fragment of
 116                          Boundary          -> eelem "boundary"
 117                          NormalText      t -> txt t
 118                          HighlightedWord w -> eelem "hit" += txt w
 119                          -<< ()
 120
 121
 122 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 123 searchResultToXHTML env
 124     = proc tree
 125     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 126           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 127           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 128           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 129
 130           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 131               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 132
 133           pageTitle    <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
 134           leftSideBar  <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
 135           rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
 136
 137           ( eelem "/"
 138             += ( eelem "html"
 139                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 140                  += ( eelem "head"
 141                       += ( eelem "title"
 142                            += txt siteName
 143                            += txt " - "
 144                            += getXPathTreesInDoc "/searchResult/@query/text()"
 145                          )
 146                       += ( constL cssHref
 147                            >>>
 148                            eelem "link"
 149                            += sattr "rel"  "stylesheet"
 150                            += sattr "type" "text/css"
 151                            += attr "href" (arr id >>> mkText)
 152                          )
 153                       += ( constL scriptSrc
 154                            >>>
 155                            eelem "script"
 156                            += sattr "type" "text/javascript"
 157                            += attr "src" (arr id >>> mkText)
 158                          )
 159                       += ( eelem "script"
 160                            += sattr "type" "text/javascript"
 161                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 162                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 163                            += txt  "Rakka.isSpecialPage=true;"
 164                          )
 165                     )
 166                  += ( eelem "body"
 167                       += ( eelem "div"
 168                            += sattr "class" "header"
 169                          )
 170                       += ( eelem "div"
 171                            += sattr "class" "center"
 172                            += ( eelem "div"
 173                                 += sattr "class" "title"
 174                                 += constL pageTitle
 175                               )
 176                            += ( eelem "div"
 177                                 += sattr "class" "body"
 178                                 += ( eelem "h1"
 179                                      += txt "Search Result"
 180                                    )
 181                                 += ( eelem "div"
 182                                      += sattr "class" "searchStat"
 183                                      += txt "Search result for "
 184                                      += ( eelem "span"
 185                                           += sattr "class" "queryString"
 186                                           += getXPathTreesInDoc "/searchResult/@query/text()"
 187                                         )
 188                                      += txt ": found "
 189                                      += getXPathTreesInDoc "/searchResult/@total/text()"
 190                                      += txt " pages."
 191                                    )
 192                                 += ( getXPathTreesInDoc "/searchResult/page"
 193                                      >>>
 194                                      formatItem baseURI
 195                                    )
 196                                 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
 197                                          >>>
 198                                          getText
 199                                        )
 200                                        &&&
 201                                        ( getXPathTreesInDoc "/searchResult/@from/text()"
 202                                          >>>
 203                                          getText
 204                                          >>>
 205                                          arr ((`div` resultsPerSection) . read)
 206                                        )
 207                                        &&&
 208                                        ( getXPathTreesInDoc "/searchResult/@total/text()"
 209                                          >>>
 210                                          getText
 211                                          >>>
 212                                          arr ((+ 1) . (`div` resultsPerSection) . read)
 213                                        )
 214                                      )
 215                                      >>>
 216                                      ( ((> 1) . snd . snd)
 217                                        `guardsP`
 218                                        formatPager baseURI
 219                                      )
 220                                    )
 221                               )
 222                          )
 223                       += ( eelem "div"
 224                            += sattr "class" "footer"
 225                          )
 226                       += ( eelem "div"
 227                            += sattr "class" "left sideBar"
 228                            += ( eelem "div"
 229                                 += sattr "class" "content"
 230                                 += constL leftSideBar
 231                               )
 232                          )
 233                       += ( eelem "div"
 234                            += sattr "class" "right sideBar"
 235                            += ( eelem "div"
 236                                 += sattr "class" "content"
 237                                 += constL rightSideBar
 238                               )
 239                          )
 240                     )
 241                  >>>
 242                  uniqueNamespacesFromDeclAndQNames
 243                ) ) -<< tree
 244     where
 245       formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
 246       formatItem baseURI
 247           = ( eelem "div"
 248               += sattr "class" "searchResult"
 249               += ( eelem "a"
 250                    += attr "href" ( getAttrValue "name"
 251                                     >>>
 252                                     arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 253                                     >>>
 254                                     mkText
 255                                   )
 256                    += (getAttrValue "name" >>> mkText)
 257                  )
 258               += ( eelem "p"
 259                    += ( getChildren
 260                         >>>
 261                         choiceA [ isText             :-> this
 262                                 , hasName "boundary" :-> txt " ... "
 263                                 , hasName "hit"      :-> ( eelem "span"
 264                                                            += sattr "class" "highlighted"
 265                                                            += getChildren
 266                                                          )
 267                                 ]
 268                       )
 269                  )
 270             )
 271
 272       formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
 273       formatPager baseURI
 274           = ( eelem "div"
 275               += sattr "class" "pager"
 276               += txt "Page."
 277               += ( ( arr fst
 278                      &&&
 279                      arr (fst . snd)
 280                      &&&
 281                      ( arr snd
 282                        >>>
 283                        mkSectionWindow
 284                      )
 285                    )
 286                    >>>
 287                    proc (query, (currentSection, section))
 288                        -> if currentSection == section then
 289                               ( txt " "
 290                                 <+>
 291                                 eelem "span"
 292                                 += sattr "class" "currentSection"
 293                                 += (arr show >>> mkText)
 294                               ) -< section
 295                           else
 296                               ( txt " "
 297                                 <+>
 298                                 eelem "a"
 299                                 += attr "href" ( mkSectionURI baseURI
 300                                                  >>>
 301                                                  uriToText
 302                                                )
 303                                 += (arr (show . snd) >>> mkText)
 304                               ) -< (query, section)
 305                  )
 306             )
 307
 308       mkSectionWindow :: ArrowList a => a (Int, Int) Int
 309       mkSectionWindow
 310           = proc (currentSection, totalSections)
 311           -> let windowWidth  = min maxSectionWindowSize totalSections
 312                  windowBegin  = currentSection - (windowWidth `div` 2)
 313                  (begin, end) = if windowBegin < 0 then
 314                                     -- 左に溢れた
 315                                     (0, windowWidth - 1)
 316                                 else
 317                                     if windowBegin + windowWidth >= totalSections then
 318                                         -- 右に溢れた
 319                                         (totalSections - windowWidth, totalSections - 1)
 320                                     else
 321                                         -- どちらにも溢れない
 322                                         (windowBegin, windowBegin + windowWidth - 1)
 323              in
 324                arrL id -< [begin .. end]
 325
 326
 327       mkSectionURI :: Arrow a => URI -> a (String, Int) URI
 328       mkSectionURI baseURI
 329           = arr $ \ (query, section)
 330           -> baseURI {
 331                uriPath  = uriPath baseURI </> "search"
 332              , uriQuery = '?' : mkQueryString [ ("q"   , query)
 333                                               , ("from", show $ section * resultsPerSection)
 334                                               , ("to"  , show $ (section + 1) * resultsPerSection - 1)
 335                                               ]
 336              }
 337
 338       uriToText :: ArrowXml a => a URI XmlTree
 339       uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
 340
 341       mkQueryString :: [(String, String)] -> String
 342       mkQueryString []            = ""
 343       mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
 344                                     if xs == [] then
 345                                         ""
 346                                     else
 347                                         ';' : mkQueryString(xs)
 348
 349       encode :: String -> String
 350       encode = escapeURIString isSafeChar . UTF8.encodeString
 351
 352
 353 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 354                Environment
 355             -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
 356 readSubPage env
 357     = proc (mainPageName, mainPage, subPageName) ->
 358       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 359          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 360                      -< (mainPageName, mainPage, subPage)
 361          returnA -< subXHTML