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