Rakka/Resource/Search.hs

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