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           Network.HTTP.Lucu
  15 import           Network.URI hiding (query, fragment)
  16 import           Rakka.Environment
  17 import           Rakka.Page
  18 import           Rakka.Resource
  19 import           Rakka.Storage
  20 import           Rakka.SystemConfig
  21 import           Rakka.Utils
  22 import           Rakka.Wiki.Engine
  23 import           System.FilePath
  24 import           Text.HyperEstraier
  25 import           Text.XML.HXT.Arrow.Namespace
  26 import           Text.XML.HXT.Arrow.XmlArrow
  27 import           Text.XML.HXT.Arrow.XmlNodeSet
  28 import           Text.XML.HXT.DOM.TypeDefs
  29
  30
  31 resSearch :: Environment -> ResourceDef
  32 resSearch env
  33     = ResourceDef {
  34         resUsesNativeThread = False
  35       , resIsGreedy         = False
  36       , resGet              = Just $ handleSearch env
  37       , resHead             = Nothing
  38       , resPost             = Nothing
  39       , resPut              = Nothing
  40       , resDelete           = Nothing
  41       }
  42
  43
  44 {-
  45   <searchResult query="foo bar baz"
  46                 from="0"
  47                 to="5"
  48                 total="5">
  49
  50     <page name="Page/1">
  51       aaa <hit>foo</hit> bbb
  52     </page>
  53
  54     ...
  55   </searchResult>
  56 -}
  57 handleSearch :: Environment -> Resource ()
  58 handleSearch env
  59     = do params <- getQueryForm
  60
  61          let query = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
  62              from  = read $ fromMaybe "0"  $ lookup "from" params
  63              to    = read $ fromMaybe "20" $ lookup "to"   params
  64
  65          cond   <- liftIO $ mkCond query from to
  66          result <- searchPages (envStorage env) cond
  67
  68          let to' = min (from + length result) to
  69
  70          runIdempotentA $ proc ()
  71              -> do tree <- ( eelem "/"
  72                              += ( eelem "searchResult"
  73                                   += sattr "query" query
  74                                   += sattr "from"  (show from)
  75                                   += sattr "to"    (show to')
  76                                   += sattr "total" (show $ length result)
  77                                   += ( constL result
  78                                        >>>
  79                                        mkPageElem
  80                                      )
  81                                 )
  82                            ) -< ()
  83                    returnA -< outputXmlPage' tree (searchResultToXHTML env)
  84     where
  85       mkCond :: String -> Int -> Int -> IO Condition
  86       mkCond query from to
  87           = do cond <- newCondition
  88                setPhrase cond query
  89                setSkip   cond from
  90                setMax    cond (to - from)
  91                return cond
  92
  93       mkPageElem :: ArrowXml a => a SearchResult XmlTree
  94       mkPageElem = ( eelem "page"
  95                      += attr "name" (arr srPageName >>> mkText)
  96                      += ( arrL srSnippet
  97                           >>>
  98                           mkSnippetTree
  99                         )
 100                    )
 101
 102       mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
 103       mkSnippetTree = proc fragment
 104                     -> case fragment of
 105                          Boundary          -> eelem "boundary"
 106                          NormalText      t -> txt t
 107                          HighlightedWord w -> eelem "hit" += txt w
 108                          -<< ()
 109
 110
 111 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 112 searchResultToXHTML env
 113     = proc tree
 114     -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
 115           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
 116           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 117           GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
 118
 119           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
 120               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 121
 122           pageTitle    <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
 123           leftSideBar  <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
 124           rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
 125
 126           ( eelem "/"
 127             += ( eelem "html"
 128                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
 129                  += ( eelem "head"
 130                       += ( eelem "title"
 131                            += txt siteName
 132                            += txt " - "
 133                            += getXPathTreesInDoc "/searchResult/@query/text()"
 134                          )
 135                       += ( constL cssHref
 136                            >>>
 137                            eelem "link"
 138                            += sattr "rel"  "stylesheet"
 139                            += sattr "type" "text/css"
 140                            += attr "href" (arr id >>> mkText)
 141                          )
 142                       += ( constL scriptSrc
 143                            >>>
 144                            eelem "script"
 145                            += sattr "type" "text/javascript"
 146                            += attr "src" (arr id >>> mkText)
 147                          )
 148                       += ( eelem "script"
 149                            += sattr "type" "text/javascript"
 150                            += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
 151                            += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
 152                            += txt  "Rakka.isSpecialPage=true;"
 153                          )
 154                     )
 155                  += ( eelem "body"
 156                       += ( eelem "div"
 157                            += sattr "class" "header"
 158                          )
 159                       += ( eelem "div"
 160                            += sattr "class" "center"
 161                            += ( eelem "div"
 162                                 += sattr "class" "title"
 163                                 += constL pageTitle
 164                               )
 165                            += ( eelem "div"
 166                                 += sattr "class" "body"
 167                                 += ( eelem "h1"
 168                                      += txt "Search Result"
 169                                    )
 170                                 += ( eelem "div"
 171                                      += sattr "class" "searchStat"
 172                                      += txt "Search result for "
 173                                      += ( eelem "span"
 174                                           += sattr "class" "queryString"
 175                                           += getXPathTreesInDoc "/searchResult/@query/text()"
 176                                         )
 177                                      += txt ": found "
 178                                      += getXPathTreesInDoc "/searchResult/@total/text()"
 179                                      += txt " pages."
 180                                    )
 181                                 += ( getXPathTreesInDoc "/searchResult/page"
 182                                      >>>
 183                                      eelem "div"
 184                                      += sattr "class" "searchResult"
 185                                      += ( eelem "a"
 186                                           += attr "href" ( getAttrValue "name"
 187                                                            >>>
 188                                                            arr (\ x -> uriToString id (mkPageURI baseURI x) "")
 189                                                            >>>
 190                                                            mkText
 191                                                          )
 192                                           += (getAttrValue "name" >>> mkText)
 193                                         )
 194                                      += ( eelem "p"
 195                                           += ( getChildren
 196                                                >>>
 197                                                choiceA [ isText             :-> this
 198                                                        , hasName "boundary" :-> txt " ... "
 199                                                        , hasName "hit"      :-> ( eelem "span"
 200                                                                                   += sattr "class" "highlighted"
 201                                                                                   += getChildren
 202                                                                                 )
 203                                                        ]
 204                                              )
 205                                         )
 206                                    )
 207                               )
 208                          )
 209                       += ( eelem "div"
 210                            += sattr "class" "footer"
 211                          )
 212                       += ( eelem "div"
 213                            += sattr "class" "left sideBar"
 214                            += ( eelem "div"
 215                                 += sattr "class" "content"
 216                                 += constL leftSideBar
 217                               )
 218                          )
 219                       += ( eelem "div"
 220                            += sattr "class" "right sideBar"
 221                            += ( eelem "div"
 222                                 += sattr "class" "content"
 223                                 += constL rightSideBar
 224                               )
 225                          )
 226                     )
 227                  >>>
 228                  uniqueNamespacesFromDeclAndQNames
 229                ) ) -<< tree
 230
 231
 232 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 233                Environment
 234             -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
 235 readSubPage env
 236     = proc (mainPageName, mainPage, subPageName) ->
 237       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
 238          subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
 239                      -< (mainPageName, mainPage, subPage)
 240          returnA -< subXHTML