improvements related to page search

[Rakka.git] / Rakka / Resource / Search.hs

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index 8271640847fb3a8df9ee1f8b8cfbd3dba0faedba..a7e7628918732f050a5759aa99e339ef261b001a 100644 (file)
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -3,17 +3,28 @@ module Rakka.Resource.Search
     )
     where
 
+import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
+import           Control.Arrow.ArrowIf
 import           Control.Arrow.ArrowList
+import           Control.Arrow.ArrowTree
 import           Control.Monad.Trans
 import           Data.Maybe
 import           Network.HTTP.Lucu
+import           Network.URI hiding (query, fragment)
 import           Rakka.Environment
+import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Storage
+import           Rakka.SystemConfig
+import           Rakka.Utils
+import           Rakka.Wiki.Engine
+import           System.FilePath
 import           Text.HyperEstraier
+import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlNodeSet
 import           Text.XML.HXT.DOM.TypeDefs
 
 
@@ -47,7 +58,7 @@ handleSearch :: Environment -> Resource ()
 handleSearch env
     = do params <- getQueryForm
 
-         let query = fromMaybe ""  $ lookup "q" params
+         let query = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
              from  = read $ fromMaybe "0"  $ lookup "from" params
              to    = read $ fromMaybe "20" $ lookup "to"   params
 
@@ -91,6 +102,7 @@ handleSearch env
       mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
       mkSnippetTree = proc fragment
                     -> case fragment of
+                         Boundary          -> eelem "boundary"
                          NormalText      t -> txt t
                          HighlightedWord w -> eelem "hit" += txt w
                          -<< ()
@@ -99,4 +111,130 @@ handleSearch env
 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 searchResultToXHTML env
     = proc tree
-    -> this -< tree
+    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
+          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
+          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
+
+          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+          pageTitle    <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
+
+          ( eelem "/"
+            += ( eelem "html"
+                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                 += ( eelem "head"
+                      += ( eelem "title"
+                           += txt siteName
+                           += txt " - "
+                           += getXPathTreesInDoc "/searchResult/@query/text()"
+                         )
+                      += ( constL cssHref
+                           >>>
+                           eelem "link"
+                           += sattr "rel"  "stylesheet"
+                           += sattr "type" "text/css"
+                           += attr "href" (arr id >>> mkText)
+                         )
+                      += ( constL scriptSrc
+                           >>>
+                           eelem "script"
+                           += sattr "type" "text/javascript"
+                           += attr "src" (arr id >>> mkText)
+                         )
+                      += ( eelem "script"
+                           += sattr "type" "text/javascript"
+                           += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
+                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+                           += txt  "Rakka.isSpecialPage=true;"
+                         )
+                    )
+                 += ( eelem "body"
+                      += ( eelem "div"
+                           += sattr "class" "header"
+                         )
+                      += ( eelem "div"
+                           += sattr "class" "center"
+                           += ( eelem "div"
+                                += sattr "class" "title"
+                                += constL pageTitle
+                              )
+                           += ( eelem "div"
+                                += sattr "class" "body"
+                                += ( eelem "h1"
+                                     += txt "Search Result"
+                                   )
+                                += ( eelem "div"
+                                     += sattr "class" "searchStat"
+                                     += txt "Search result for "
+                                     += ( eelem "span"
+                                          += sattr "class" "queryString"
+                                          += getXPathTreesInDoc "/searchResult/@query/text()"
+                                        )
+                                     += txt ": found "
+                                     += getXPathTreesInDoc "/searchResult/@total/text()"
+                                     += txt " pages."
+                                   )
+                                += ( getXPathTreesInDoc "/searchResult/page"
+                                     >>>
+                                     eelem "div"
+                                     += sattr "class" "searchResult"
+                                     += ( eelem "a"
+                                          += attr "href" ( getAttrValue "name"
+                                                           >>>
+                                                           arr (\ x -> uriToString id (mkPageURI baseURI x) "")
+                                                           >>>
+                                                           mkText
+                                                         )
+                                          += (getAttrValue "name" >>> mkText)
+                                        )
+                                     += ( eelem "p"
+                                          += ( getChildren
+                                               >>>
+                                               choiceA [ isText             :-> this
+                                                       , hasName "boundary" :-> txt " ... "
+                                                       , hasName "hit"      :-> ( eelem "span"
+                                                                                  += sattr "class" "highlighted"
+                                                                                  += getChildren
+                                                                                )
+                                                       ]
+                                             )
+                                        )
+                                   )
+                              )
+                         )
+                      += ( eelem "div"
+                           += sattr "class" "footer"
+                         )
+                      += ( eelem "div"
+                           += sattr "class" "left sideBar"
+                           += ( eelem "div"
+                                += sattr "class" "content"
+                                += constL leftSideBar
+                              )
+                         )
+                      += ( eelem "div"
+                           += sattr "class" "right sideBar"
+                           += ( eelem "div"
+                                += sattr "class" "content"
+                                += constL rightSideBar
+                              )
+                         )
+                    )
+                 >>>
+                 uniqueNamespacesFromDeclAndQNames
+               ) ) -<< tree
+
+
+readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+               Environment
+            -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
+readSubPage env
+    = proc (mainPageName, mainPage, subPageName) ->
+      do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
+         subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
+                     -< (mainPageName, mainPage, subPage)
+         returnA -< subXHTML