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