merge branch origin/master

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

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index eb4acf253d11c4d0535bed1c25082fc350e58fec..2d076e890556db5da7e04bb29e5aa9f730b92e56 100644 (file)
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -1,15 +1,33 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.Search
     ( resSearch
     )
     where
 module Rakka.Resource.Search
     ( resSearch
     )
     where

+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Arrow.Unicode
+import qualified Codec.Binary.UTF8.Generic as UTF8

 import           Control.Monad.Trans
 import           Control.Monad.Trans

-import           Data.List
+import qualified Data.ByteString.Char8 as C8

 import           Data.Maybe
 import           Data.Maybe

+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T

 import           Data.Time
 import qualified Data.Time.RFC1123 as RFC1123
 import qualified Data.Time.W3C as W3C
 import           Network.HTTP.Lucu
 import           Network.URI hiding (query, fragment)
 import           Data.Time
 import qualified Data.Time.RFC1123 as RFC1123
 import qualified Data.Time.W3C as W3C
 import           Network.HTTP.Lucu
 import           Network.URI hiding (query, fragment)

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource


@@ -19,8 +37,10 @@ import           Rakka.Utils
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           Text.HyperEstraier hiding (getText)
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           Text.HyperEstraier hiding (getText)

-import           Text.XML.HXT.XPath
-
+import Text.XML.HXT.Arrow.Namespace
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath

 
 resSearch :: Environment -> ResourceDef
 resSearch env
 
 resSearch :: Environment -> ResourceDef
 resSearch env


@@ -42,11 +62,9 @@ resultsPerSection = 10
 maxSectionWindowSize :: Int
 maxSectionWindowSize = 10
 
 maxSectionWindowSize :: Int
 maxSectionWindowSize = 10
 

-
-findQueryParam :: String -> [FormData] -> Maybe String
+findQueryParam ∷ String → [(String, FormData)] → Maybe String

 findQueryParam name qps
 findQueryParam name qps

-    = do fd <- find (\ qp -> fdName qp == name) qps
-         return $ UTF8.toString $ fdContent fd
+    = UTF8.toString ∘ fdContent <$> lookup name qps

 
 {-
   <searchResult query="foo bar baz"
 
 {-
   <searchResult query="foo bar baz"


@@ -61,9 +79,9 @@ findQueryParam name qps
     ...
   </searchResult>
 -}
     ...
   </searchResult>
 -}

-handleSearch :: Environment -> Resource ()
+handleSearch ∷ Environment → Resource ()

 handleSearch env
 handleSearch env

-    = do params <- getQueryForm
+    = do params ← getQueryForm

 
          let query = fromMaybe "" $ findQueryParam "q" params
              order = findQueryParam "order" params
 
          let query = fromMaybe "" $ findQueryParam "q" params
              order = findQueryParam "order" params


@@ -72,224 +90,219 @@ handleSearch env
              to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ findQueryParam "to" params
 
              to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ findQueryParam "to" params
 

-         cond   <- liftIO $ mkCond query order from to
-         result <- searchPages (envStorage env) cond
+         cond   ← liftIO $ mkCond (T.pack query) (T.pack <$> order) from to
+         result ← searchPages (envStorage env) cond

 
          let to' = min (from + length (srPages result)) to
 
 
          let to' = min (from + length (srPages result)) to
 

-         BaseURI baseURI <- getSysConf (envSysConf env)
+         BaseURI baseURI ← getSysConf (envSysConf env)

          runIdempotentA baseURI $ proc ()
          runIdempotentA baseURI $ proc ()

-             -> do tree <- ( eelem "/"
-                             += ( eelem "searchResult"
-                                  += sattr "query" query
-                                  += ( case order of
-                                         Just o  -> sattr "order" o
-                                         Nothing -> none
-                                     )
-                                  += sattr "from"  (show from)
-                                  += sattr "to"    (show to')
-                                  += sattr "total" (show $ srTotal result)
-                                  += ( constL (srPages result)
-                                       >>>
-                                       mkPageElem
-                                     )
-                                )
-                           ) -< ()
-                   returnA -< outputXmlPage' tree (searchResultToXHTML env)
+             → do tree ← ( eelem "/"
+                           += ( eelem "searchResult"
+                                += sattr "query" query
+                                += ( case order of
+                                       Just o  → sattr "order" o
+                                       Nothing → none
+                                   )
+                                += sattr "from"  (show from)
+                                += sattr "to"    (show to')
+                                += sattr "total" (show $ srTotal result)
+                                += ( constL (srPages result)
+                                     ⋙
+                                     mkPageElem
+                                   )
+                              )
+                         ) ⤙ ()
+                  returnA ⤙ outputXmlPage' tree (searchResultToXHTML env)

     where
     where

-      mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
+      mkCond ∷ Text → Maybe Text → Int → Int → IO Condition

       mkCond query order from to
       mkCond query order from to

-          = do cond <- newCondition
+          = do cond ← newCondition

                setPhrase cond query
                case order of
                setPhrase cond query
                case order of

-                 Just o  -> setOrder cond o
-                 Nothing -> return ()
-               setSkip   cond from
-               setMax    cond (to - from + 1)
-               return cond
+                 Just o  → setOrder cond o
+                 Nothing → return ()
+               setSkip cond from
+               setMax  cond (to - from + 1)
+               pure cond

 
 

-      mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
+      mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree

       mkPageElem = ( eelem "page"
       mkPageElem = ( eelem "page"

-                     += attr "name" (arr hpPageName >>> mkText)
-                     += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
-                                              >>>
+                     += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
+                     += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
+                                              ⋙

                                               arr W3C.format
                                               arr W3C.format

-                                              >>>
+                                              ⋙

                                               mkText
                                             )
                      += ( arrL hpSnippet
                                               mkText
                                             )
                      += ( arrL hpSnippet

-                          >>>
+                          ⋙

                           mkSnippetTree
                         )
                    )
 
                           mkSnippetTree
                         )
                    )
 

-      mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
+      mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree

       mkSnippetTree = proc fragment
       mkSnippetTree = proc fragment

-                    -> case fragment of
-                         Boundary          -> eelem "boundary" -< ()
-                         NormalText      t -> mkText           -< t
-                         HighlightedWord w -> ( eelem "hit"
-                                                += mkText
-                                              ) -< w
-
+                    → case fragment of
+                        Boundary          → eelem "boundary" ⤙ ()
+                        NormalText      t → mkText           ⤙ T.unpack t
+                        HighlightedWord w → ( eelem "hit"
+                                              += mkText
+                                            ) ⤙ T.unpack w

 
 

-searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+searchResultToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                    ⇒ Environment
+                    → XmlTree ⇝ XmlTree

 searchResultToXHTML env
     = proc tree
 searchResultToXHTML env
     = proc tree

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
-          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
+    → 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" }) ""]
+         let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+             scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]

 
 

-          pageTitle    <- listA (readSubPage env) -< "PageTitle"
-          leftSideBar  <- listA (readSubPage env) -< "SideBar/Left"
-          rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
+         pageTitle    ← listA (readSubPage env) ⤙ "PageTitle"
+         leftSideBar  ← listA (readSubPage env) ⤙ "SideBar/Left"
+         rightSideBar ← listA (readSubPage env) ⤙ "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"
-                                     >>>
-                                     formatItem baseURI
-                                   )
-                                += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
-                                         >>>
-                                         getText
-                                       )
-                                       &&&
-                                       maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
-                                                >>>
-                                                getText
-                                              )
-                                       &&&
-                                       ( getXPathTreesInDoc "/searchResult/@from/text()"
-                                         >>>
-                                         getText
-                                         >>>
-                                         arr ((`div` resultsPerSection) . read)
-                                       )
-                                       &&&
-                                       ( getXPathTreesInDoc "/searchResult/@total/text()"
-                                         >>>
-                                         getText
-                                         >>>
-                                         arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
+         ( eelem "/"
+           += ( eelem "html"
+                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                += ( eelem "head"
+                     += ( eelem "title"
+                          += txt (T.unpack 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()"

                                        )
                                        )

-                                     )
-                                     >>>
-                                     ( ((> 1) . snd . snd . snd)
-                                       `guardsP`
-                                       formatPager baseURI
-                                     )
-                                   )
-                              )
-                         )
-                      += ( 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
+                                    += txt ": found "
+                                    += getXPathTreesInDoc "/searchResult/@total/text()"
+                                    += txt " pages."
+                                  )
+                               += ( getXPathTreesInDoc "/searchResult/page"
+                                    ⋙
+                                    formatItem baseURI
+                                  )
+                               += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
+                                        ⋙
+                                        getText
+                                      )
+                                      &&&
+                                      maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+                                               ⋙
+                                               getText
+                                             )
+                                      &&&
+                                      ( getXPathTreesInDoc "/searchResult/@from/text()"
+                                        ⋙
+                                        getText
+                                        ⋙
+                                        arr ((`div` resultsPerSection) . read)
+                                      )
+                                      &&&
+                                      ( getXPathTreesInDoc "/searchResult/@total/text()"
+                                        ⋙
+                                        getText
+                                        ⋙
+                                        arr ((+ 1) . (`div` resultsPerSection) . (\x → x - 1) . read) ) )
+                                    ⋙
+                                    ( ((> 1) . snd . snd . snd)
+                                      `guardsP`
+                                      formatPager baseURI ) ) ) )
+                     += ( 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

     where
     where

-      formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
+      formatItem ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                 ⇒ URI
+                 → XmlTree ⇝ XmlTree

       formatItem baseURI
           = ( eelem "div"
               += sattr "class" "searchResult"
               += ( eelem "a"
                    += attr "href" ( getAttrValue "name"
       formatItem baseURI
           = ( eelem "div"
               += sattr "class" "searchResult"
               += ( eelem "a"
                    += attr "href" ( getAttrValue "name"

-                                    >>>
-                                    arr (\ x -> uriToString id (mkPageURI baseURI x) "")
-                                    >>>
+                                    ⋙
+                                    arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "")
+                                    ⋙

                                     mkText
                                   )
                                     mkText
                                   )

-                   += (getAttrValue "name" >>> mkText)
+                   += (getAttrValue "name" ⋙ mkText)

                  )
               += ( eelem "div"
                    += sattr "class" "date"
                    += ( getAttrValue "lastModified"
                  )
               += ( eelem "div"
                    += sattr "class" "date"
                    += ( getAttrValue "lastModified"

-                        >>>
+                        ⋙

                         arr (zonedTimeToUTC . fromJust . W3C.parse)
                         arr (zonedTimeToUTC . fromJust . W3C.parse)

-                        >>>
+                        ⋙

                         arrIO utcToLocalZonedTime
                         arrIO utcToLocalZonedTime

-                        >>>
+                        ⋙

                         arr RFC1123.format
                         arr RFC1123.format

-                        >>>
+                        ⋙

                         mkText
                       )
                  )
               += ( eelem "p"
                    += ( getChildren
                         mkText
                       )
                  )
               += ( eelem "p"
                    += ( getChildren

-                        >>>
+                        ⋙

                         choiceA [ isText             :-> this
                                 , hasName "boundary" :-> txt " ... "
                                 , hasName "hit"      :-> ( eelem "span"
                         choiceA [ isText             :-> this
                                 , hasName "boundary" :-> txt " ... "
                                 , hasName "hit"      :-> ( eelem "span"


@@ -313,29 +326,29 @@ searchResultToXHTML env
                      arr (fst . snd . snd)
                      &&&
                      ( arr (snd . snd)
                      arr (fst . snd . snd)
                      &&&
                      ( arr (snd . snd)

-                       >>>
+                       ⋙

                        mkSectionWindow
                      )
                    )
                        mkSectionWindow
                      )
                    )

-                   >>>
+                   ⋙

                    proc (query, (order, (currentSection, section)))
                        -> if currentSection == section then
                               ( txt " "
                                 <+> 
                                 eelem "span"
                                 += sattr "class" "currentSection"
                    proc (query, (order, (currentSection, section)))
                        -> if currentSection == section then
                               ( txt " "
                                 <+> 
                                 eelem "span"
                                 += sattr "class" "currentSection"

-                                += (arr show >>> mkText)
-                              ) -< section
+                                += (arr show ⋙ mkText)
+                              ) ⤙ section

                           else
                               ( txt " "
                                 <+>
                                 eelem "a"
                                 += attr "href" ( mkSectionURI baseURI
                           else
                               ( txt " "
                                 <+>
                                 eelem "a"
                                 += attr "href" ( mkSectionURI baseURI

-                                                 >>>
+                                                 ⋙

                                                  uriToText
                                                )
                                                  uriToText
                                                )

-                                += (arr (show . snd . snd) >>> mkText)
-                              ) -< (query, (order, section))
+                                += (arr (show . snd . snd) ⋙ mkText)
+                              ) ⤙ (query, (order, section))

                  )
             )
 
                  )
             )
 


@@ -355,7 +368,7 @@ searchResultToXHTML env
                                         -- どちらにも溢れない
                                         (windowBegin, windowBegin + windowWidth - 1)
              in
                                         -- どちらにも溢れない
                                         (windowBegin, windowBegin + windowWidth - 1)
              in

-               arrL id -< [begin .. end]
+               arrL id ⤙ [begin .. end]

                        
 
       mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
                        
 
       mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI


@@ -363,19 +376,19 @@ searchResultToXHTML env
           = arr $ \ (query, (order, section))
           -> baseURI {
                uriPath  = uriPath baseURI </> "search.html"
           = arr $ \ (query, (order, section))
           -> baseURI {
                uriPath  = uriPath baseURI </> "search.html"

-             , uriQuery = '?' : mkQueryString ( [ ("q"   , query)
-                                                , ("from", show $ section * resultsPerSection)
-                                                , ("to"  , show $ (section + 1) * resultsPerSection - 1)
-                                                ]
-                                                ++ 
-                                                case order of
-                                                  Just o  -> [("order", o)]
-                                                  Nothing -> []
-                                              )
+             , uriQuery = '?' : C8.unpack (mkQueryString ( [ ("q"   , T.pack query)
+                                                           , ("from", T.pack ∘ show $ section       ⋅ resultsPerSection    )
+                                                           , ("to"  , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1)
+                                                           ]
+                                                           ++
+                                                           case order of
+                                                             Just o  -> [("order", T.pack o)]
+                                                             Nothing -> []
+                                                         ))

              }
 
       uriToText :: ArrowXml a => a URI XmlTree
              }
 
       uriToText :: ArrowXml a => a URI XmlTree

-      uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+      uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText

 
 
 -- FIXME: localize
 
 
 -- FIXME: localize


@@ -383,6 +396,6 @@ readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Environment -> a PageName XmlTree
 readSubPage env
     = proc (subPageName) ->
                Environment -> a PageName XmlTree
 readSubPage env
     = proc (subPageName) ->

-      do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
-         subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)
-         returnA -< subXHTML
+      do subPage  ← getPageA (envStorage env) ⋙ arr fromJust ⋙ xmlizePage ⤙ (subPageName, Nothing)
+         subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) ⤙ (Nothing, Nothing, subPage)
+         returnA ⤙ subXHTML