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