Rakka/Resource/Search.hs

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