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