Rakka/Resource/Search.hs

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