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