( resSearch
)
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.List
import Data.Maybe
import Data.Time
+import qualified Data.Time.RFC1123 as RFC1123
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
-import Network.HTTP.Lucu.RFC1123DateTime
import Network.URI hiding (query, fragment)
import Rakka.Environment
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
-import Text.XML.HXT.Arrow.Namespace
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
-import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
resSearch :: Environment -> ResourceDef
maxSectionWindowSize = 10
+findQueryParam :: String -> [FormData] -> Maybe String
+findQueryParam name qps
+ = do fd <- find (\ qp -> fdName qp == name) qps
+ return $ UTF8.toString $ fdContent fd
+
{-
<searchResult query="foo bar baz"
from="0"
handleSearch env
= do params <- getQueryForm
- let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
- order = fmap UTF8.decodeString (lookup "order" params)
+ let query = fromMaybe "" $ findQueryParam "q" params
+ order = findQueryParam "order" params
from = fromMaybe 0
- $ fmap read $ lookup "from" params
+ $ fmap read $ findQueryParam "from" params
to = fromMaybe (from + resultsPerSection)
- $ fmap read $ lookup "to" params
+ $ fmap read $ findQueryParam "to" params
cond <- liftIO $ mkCond query order from to
result <- searchPages (envStorage env) cond
+= attr "name" (arr hpPageName >>> mkText)
+= attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
>>>
- arr formatW3CDateTime
+ arr W3C.format
>>>
mkText
)
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")
+ pageTitle <- listA (readSubPage env) -< "PageTitle"
+ leftSideBar <- listA (readSubPage env) -< "SideBar/Left"
+ rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
( eelem "/"
+= ( eelem "html"
+= sattr "class" "date"
+= ( getAttrValue "lastModified"
>>>
- arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+ arr (zonedTimeToUTC . fromJust . W3C.parse)
>>>
arrIO utcToLocalZonedTime
>>>
- arr formatRFC1123DateTime
+ arr RFC1123.format
>>>
mkText
)
uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+-- FIXME: localize
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
+ Environment -> a PageName XmlTree
readSubPage env
- = proc (mainPageName, mainPage, subPageName) ->
+ = proc (subPageName) ->
do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
- subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
- -< (mainPageName, mainPage, subPage)
+ subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)
returnA -< subXHTML