From: pho Date: Sat, 15 Mar 2008 06:20:49 +0000 (+0900) Subject: List all pages X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=9d86882fe1630c844e11cf2cf760110c04ea10d4;p=Rakka.git List all pages darcs-hash:20080315062049-62b54-38e0100d656ea99fb2019d4f22babffcd3a69094.gz --- diff --git a/Rakka/Page.hs b/Rakka/Page.hs index a9dbe4f..114e2d0 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -12,7 +12,6 @@ module Rakka.Page , pageUpdateInfo , pageRevision - , isSafeChar , encodePageName , decodePageName @@ -133,14 +132,6 @@ encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) -isSafeChar :: Char -> Bool -isSafeChar c - | c == '/' = True - | isReserved c = False - | c > ' ' && c <= '~' = True - | otherwise = False - - -- URI unescape して UTF-8 から decode する。 decodePageName :: FilePath -> PageName decodePageName = UTF8.decodeString . unEscapeString diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index 6624e9e..6f72195 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -70,12 +70,13 @@ handleSearch env = 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 @@ -85,6 +86,10 @@ handleSearch 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) @@ -96,12 +101,15 @@ handleSearch env ) -< () 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 @@ -208,6 +216,11 @@ searchResultToXHTML env getText ) &&& + maybeA ( getXPathTreesInDoc "/searchResult/@order/text()" + >>> + getText + ) + &&& ( getXPathTreesInDoc "/searchResult/@from/text()" >>> getText @@ -219,11 +232,11 @@ searchResultToXHTML env >>> getText >>> - arr ((+ 1) . (`div` resultsPerSection) . read) + arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read) ) ) >>> - ( ((> 1) . snd . snd) + ( ((> 1) . snd . snd . snd) `guardsP` formatPager baseURI ) @@ -292,7 +305,7 @@ searchResultToXHTML env ) ) - 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" @@ -301,13 +314,15 @@ searchResultToXHTML env &&& 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 " " <+> @@ -323,8 +338,8 @@ searchResultToXHTML env >>> uriToText ) - += (arr (show . snd) >>> mkText) - ) -< (query, section) + += (arr (show . snd . snd) >>> mkText) + ) -< (query, (order, section)) ) ) @@ -347,31 +362,25 @@ searchResultToXHTML env 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 diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index 693fdf2..15bc6f4 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -6,15 +6,19 @@ module Rakka.Utils , 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 @@ -63,3 +67,23 @@ guessMIMEType = read . unsafePerformIO . magicString magic . L8.unpack $ 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 diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs index 8631c8b..fd4d364 100644 --- a/Rakka/Wiki/Interpreter/PageList.hs +++ b/Rakka/Wiki/Interpreter/PageList.hs @@ -7,15 +7,36 @@ import Control.Monad 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") + } --
diff --git a/defaultPages/SideBar/Right.xml b/defaultPages/SideBar/Right.xml index e2a00a2..982e863 100644 --- a/defaultPages/SideBar/Right.xml +++ b/defaultPages/SideBar/Right.xml @@ -12,6 +12,7 @@ = Recent updates = + ]]>