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