= do params <- getQueryForm
let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
+ order = fmap UTF8.decodeString (lookup "order" params)
from = fromMaybe 0
$ fmap read $ lookup "from" params
to = fromMaybe (from + resultsPerSection)
$ fmap read $ lookup "to" params
- cond <- liftIO $ mkCond query from to
+ cond <- liftIO $ mkCond query order from to
result <- searchPages (envStorage env) cond
let to' = min (from + length (srPages result)) to
-> 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)
) -< ()
returnA -< outputXmlPage' tree (searchResultToXHTML env)
where
- mkCond :: String -> Int -> Int -> IO Condition
- mkCond query from to
+ mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
+ mkCond query order from to
= do cond <- newCondition
setPhrase cond query
+ case order of
+ Just o -> setOrder cond o
+ Nothing -> return ()
setSkip cond from
- setMax cond (to - from)
+ setMax cond (to - from + 1)
return cond
mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
getText
)
&&&
+ maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+ >>>
+ getText
+ )
+ &&&
( getXPathTreesInDoc "/searchResult/@from/text()"
>>>
getText
>>>
getText
>>>
- arr ((+ 1) . (`div` resultsPerSection) . read)
+ arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
)
)
>>>
- ( ((> 1) . snd . snd)
+ ( ((> 1) . snd . snd . snd)
`guardsP`
formatPager baseURI
)
)
)
- formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
+ formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
formatPager baseURI
= ( eelem "div"
+= sattr "class" "pager"
&&&
arr (fst . snd)
&&&
- ( arr snd
+ arr (fst . snd . snd)
+ &&&
+ ( arr (snd . snd)
>>>
mkSectionWindow
)
)
>>>
- proc (query, (currentSection, section))
+ proc (query, (order, (currentSection, section)))
-> if currentSection == section then
( txt " "
<+>
>>>
uriToText
)
- += (arr (show . snd) >>> mkText)
- ) -< (query, section)
+ += (arr (show . snd . snd) >>> mkText)
+ ) -< (query, (order, section))
)
)
arrL id -< [begin .. end]
- mkSectionURI :: Arrow a => URI -> a (String, Int) URI
+ mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
mkSectionURI baseURI
- = arr $ \ (query, section)
+ = arr $ \ (query, (order, section))
-> baseURI {
- uriPath = uriPath baseURI </> "search"
- , uriQuery = '?' : mkQueryString [ ("q" , query)
- , ("from", show $ section * resultsPerSection)
- , ("to" , show $ (section + 1) * resultsPerSection - 1)
- ]
+ 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 -> []
+ )
}
uriToText :: ArrowXml a => a URI XmlTree
uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
- mkQueryString :: [(String, String)] -> String
- mkQueryString [] = ""
- mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
- if xs == [] then
- ""
- else
- ';' : mkQueryString(xs)
-
- encode :: String -> String
- encode = escapeURIString isSafeChar . UTF8.encodeString
-
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
, deleteIfEmpty
, chomp
, guessMIMEType
+ , isSafeChar
+ , mkQueryString
)
where
+import qualified Codec.Binary.UTF8.String as UTF8
import Control.Arrow
import Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import Magic
import Network.HTTP.Lucu
+import Network.URI
import System.IO.Unsafe
$ do m <- magicOpen [MagicMime]
magicLoadDefault m
return m
+
+
+isSafeChar :: Char -> Bool
+isSafeChar c
+ | c == '/' = True
+ | isReserved c = False
+ | c > ' ' && c <= '~' = True
+ | otherwise = False
+
+
+mkQueryString :: [(String, String)] -> String
+mkQueryString [] = ""
+mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
+ if xs == [] then
+ ""
+ else
+ ';' : mkQueryString(xs)
+ where
+ encode :: String -> String
+ encode = escapeURIString isSafeChar . UTF8.encodeString
\ No newline at end of file
import Data.Maybe
import Data.Time
import Network.HTTP.Lucu.RFC1123DateTime
+import Network.URI
import Rakka.Storage
+import Rakka.SystemConfig
import Rakka.Utils
import Rakka.Wiki
import Rakka.Wiki.Interpreter
+import System.FilePath
import Text.HyperEstraier
interpreters :: [Interpreter]
-interpreters = [ recentUpdatesInterp ]
+interpreters = [ recentUpdatesURLInterp
+ , recentUpdatesInterp
+ ]
+
+
+recentUpdatesURLInterp :: Interpreter
+recentUpdatesURLInterp
+ = InlineCommandInterpreter {
+ iciName = "recentUpdatesURL"
+ , iciInterpret
+ = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
+ let uri = baseURI {
+ uriPath = uriPath baseURI </> "search.html"
+ , uriQuery = '?' : mkQueryString [ ("q" , "[UVSET]")
+ , ("order", "@mdate NUMD")
+ ]
+ }
+ return $ ExternalLink uri (Just "List all pages")
+ }
-- <div class="recentUpdates">
projects / Rakka.git / commitdiff