From: PHO Date: Tue, 14 Feb 2012 17:29:40 +0000 (+0900) Subject: merge branch origin/master X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fmaster;p=Rakka.git merge branch origin/master --- 45bce2c29948649f74ada71f2fa851bdb812e96c diff --cc Main.hs index cf4cf88,8ea4e99..3df4d8b --- a/Main.hs +++ b/Main.hs @@@ -6,9 -3,8 +6,9 @@@ import Control.Exceptio import Control.Monad import Data.List import Data.Maybe -import Network.Socket +import Network.Socket import Network.HTTP.Lucu - import OpenSSL ++import OpenSSL import Rakka.Environment import Rakka.Resource.CheckAuth import Rakka.Resource.DumpRepos @@@ -166,7 -161,7 +165,6 @@@ resTree en , (["search.html" ], resSearch env) , (["search.xml" ], resSearch env) , (["systemConfig"], resSystemConfig env) -- -- , (["trackback" ], resTrackBack env) , (["users" ], resUsers env) ] diff --cc Rakka.cabal index 6345b45,cda8dc9..9eeac5a --- a/Rakka.cabal +++ b/Rakka.cabal @@@ -61,16 -64,32 +64,35 @@@ Flag build-test-suit Executable rakka Build-Depends: + HsHyperEstraier == 0.4.*, ++ HsOpenSSL == 0.10.*, + HsSVN == 0.4.*, + Lucu == 0.7.*, - ascii == 0.0.*, - base == 4.3.*, ++ base == 4.*, base-unicode-symbols == 0.2.*, + bytestring == 0.9.*, + case-insensitive == 0.4.*, + containers == 0.4.*, + dataenc == 0.14.*, + directory == 1.1.*, filemanip == 0.3.*, - text == 0.11.*, + filepath == 1.2.*, + hslogger == 1.1.*, - hxt == 9.1.*, ++ hxt == 9.2.*, + hxt-relaxng == 9.1.*, + hxt-xpath == 9.1.*, + magic == 1.0.*, + mtl == 2.0.*, + network == 2.3.*, + parsec == 3.1.*, + stm == 2.2.*, + text == 0.11.*, + time == 1.2.*, time-http == 0.1.*, - HTTP, HUnit, HsHyperEstraier, HsOpenSSL, HsSVN >= - 0.3.2, Lucu, base, bytestring, containers, dataenc, directory, - utf8-string, filepath, hslogger, hxt, hxt-xpath, magic, mtl, - network, parsec, stm, time, unix, zlib + time-w3c == 0.1.*, + unix == 2.4.*, ++ utf8-string == 0.3.*, + zlib == 0.5.* Main-Is: Main.hs diff --cc Rakka/Environment.hs index c526c89,9a6df3a..2de28b2 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@@ -71,27 -71,28 +70,26 @@@ setupEnv lsdir por , envAuthDB = authDB } where - makeDraft' :: InterpTable -> Page -> IO Document + makeDraft' ∷ InterpTable → Page → IO Document makeDraft' interpTable page - = do [doc] <- runX ( setErrorMsgHandler False fail - >>> - constA page - >>> - xmlizePage - >>> - makeDraft interpTable - ) + = do [doc] ← runX ( setErrorMsgHandler False fail + ⋙ + constA page + ⋙ + xmlizePage + ⋙ + makeDraft interpTable + ) return doc - -mkInterpTable :: InterpTable +mkInterpTable ∷ InterpTable mkInterpTable = listToTable $ - foldl (++) [] [ Base.interpreters - , Image.interpreters - , PageList.interpreters - --, Trackback.interpreters - , Outline.interpreters - ] + concat [ Base.interpreters + , Image.interpreters + , PageList.interpreters - --, Trackback.interpreters + , Outline.interpreters + ] where - listToTable :: [Interpreter] -> InterpTable + listToTable ∷ [Interpreter] → InterpTable listToTable xs - = M.fromList [ (commandName x, x) | x <- xs ] + = M.fromList [ (commandName x, x) | x ← xs ] diff --cc Rakka/Page.hs index f845f7e,24f037b..b4c88fc --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@@ -42,32 -38,27 +42,31 @@@ import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as L hiding (ByteString) import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import Data.Char -import Data.Map (Map) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char +import Data.Map (Map) import qualified Data.Map as M -import Data.Time +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Time + import qualified Data.Time.W3C as W3C -import Network.HTTP.Lucu hiding (redirect) -import Network.URI hiding (fragment) -import Rakka.Utils -import Subversion.Types -import System.FilePath.Posix +import Network.HTTP.Lucu hiding (redirect) +import Network.URI hiding (fragment) - import OpenSSL.EVP.Base64 ++import OpenSSL.EVP.Base64 +import Prelude.Unicode +import Rakka.Utils - import Rakka.W3CDateTime +import Subversion.Types +import System.FilePath.Posix +import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.XPath -import Text.XML.HXT.Arrow.XmlArrow -import Prelude.Unicode - -type PageName = T.Text - -type LanguageTag = Ascii -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt -type LanguageName = T.Text -- i.e. "日本語" +type PageName = Text +type LanguageTag = CI Text -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt +type LanguageName = Text -- i.e. "日本語" - data Page = Redirection { redirName :: !PageName @@@ -94,7 -85,7 +93,6 @@@ } deriving (Show, Eq) -- data UpdateInfo = UpdateInfo { uiOldRevision :: !RevNum @@@ -248,11 -239,11 +246,11 @@@ xmlizePag -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page ( eelem "/" += ( eelem "page" - += sattr "name" (redirName page) - += sattr "redirect" (redirDest page) - += sattr "isLocked" (yesOrNo $ redirIsLocked page) - += sattr "revision" (show $ redirRevision page) + += sattr "name" (T.unpack $ redirName page ) + += sattr "redirect" (T.unpack $ redirDest page ) + += sattr "isLocked" (yesOrNo $ redirIsLocked page) + += sattr "revision" (show $ redirRevision page) - += sattr "lastModified" (formatW3CDateTime lastMod) + += sattr "lastModified" (W3C.format lastMod) )) -<< () xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree @@@ -378,22 -372,18 +376,18 @@@ parseEntit , entityContent = content , entityUpdateInfo = updateInfo } - where - dropWhitespace :: String -> String - dropWhitespace [] = [] - dropWhitespace (x:xs) - | x == ' ' || x == '\t' || x == '\n' - = dropWhitespace xs - | otherwise - = x : dropWhitespace xs +parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo +parseUpdateInfo + = proc tree + -> do uInfo ← getXPathTreesInDoc "/page/updateInfo" ⤙ tree + oldRev ← (getAttrValue0 "oldRevision" ⋙ arr read) ⤙ uInfo + oldName ← maybeA (getXPathTrees "/updateInfo/move/@from/text()" ⋙ getText) ⤙ uInfo + returnA ⤙ UpdateInfo { + uiOldRevision = oldRev + , uiOldName = T.pack <$> oldName + } ++ + dropWhitespace :: String -> String + {-# INLINE dropWhitespace #-} + dropWhitespace = filter ((¬) ∘ isSpace) - -parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo -parseUpdateInfo - = proc tree - -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree - oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo - oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo - returnA -< UpdateInfo { - uiOldRevision = oldRev - , uiOldName = oldName - } diff --cc Rakka/Resource/PageEntity.hs index 1388f71,c805ae5..397f8d4 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@@ -21,12 -7,10 +21,13 @@@ import qualified Data.CaseInsensitive a import Data.Char import qualified Data.Map as M import Data.Maybe +import Data.Monoid.Unicode +import qualified Data.Text as T import Data.Time + import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu import Network.URI hiding (path) +import Prelude.Unicode import Rakka.Environment import Rakka.Page import Rakka.Resource @@@ -119,220 -100,222 +119,212 @@@ handleGetEntity en ] -entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +entityToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → XmlTree ⇝ XmlTree entityToXHTML env = proc page - -> do SiteName siteName <- getSysConfA (envSysConf env) -< () - BaseURI baseURI <- getSysConfA (envSysConf env) -< () - StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () - GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () - - name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page - isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page - - let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] - scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - - pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right") - pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page - - ( eelem "/" - += ( eelem "html" - += sattr "xmlns" "http://www.w3.org/1999/xhtml" - += ( getXPathTreesInDoc "/page/@lang" - `guards` - qattr (mkQName "xml" "lang" "") - ( getXPathTreesInDoc "/page/@lang/text()" ) - ) - += ( eelem "head" - += ( eelem "title" - += txt siteName - += txt " - " - += getXPathTreesInDoc "/page/@name/text()" - ) - += ( constL cssHref - >>> - eelem "link" - += sattr "rel" "stylesheet" - += sattr "type" "text/css" - += attr "href" (arr id >>> mkText) - ) - += mkFeedList env - += ( 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.isLocked=" ++ trueOrFalse isLocked ++ ";") - += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") - ) - += mkGlobalJSList env - ) - += ( eelem "body" - += ( eelem "div" - += sattr "class" "header" - ) - += ( eelem "div" - += sattr "class" "center" - += ( eelem "div" - += sattr "class" "title" - += constL pageTitle - ) - += ( eelem "div" - += sattr "class" "body" - += constL pageBody - ) - ) - += ( 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 - ) ) -<< page - - -entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree + → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ () + BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ () + StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ () + GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ () + + name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page + isLocked ← (getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⋙ parseYesOrNo) ⤙ page + + let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] + scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + + pageTitle ← listA (readSubPage env) ⤙ (T.pack name, Just page, "PageTitle") + leftSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Left") + rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Right") + pageBody ← listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) ⤙ page + + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( getXPathTreesInDoc "/page/@lang" + `guards` + qattr (mkQName "xml" "lang" "") + ( getXPathTreesInDoc "/page/@lang/text()" ) + ) + += ( eelem "head" + += ( eelem "title" + += txt (T.unpack siteName) + += txt " - " + += getXPathTreesInDoc "/page/@name/text()" + ) + += ( constL cssHref + ⋙ + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id ⋙ mkText) + ) + += mkFeedList env + += ( 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.isLocked=" ⊕ trueOrFalse isLocked ⊕ ";" ) + += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked ⊕ ";" ) + ) + += mkGlobalJSList env + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += constL pageBody + ) + ) + += ( 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 + ) ) ⤛ page + +entityToRSS ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → XmlTree ⇝ XmlTree entityToRSS env = proc page - -> do SiteName siteName <- getSysConfA (envSysConf env) -< () - BaseURI baseURI <- getSysConfA (envSysConf env) -< () + → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ () + BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ () - name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page - summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page - pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page + name ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page + summary ← maybeA (getXPathTreesInDoc "/page/summary/text()" ⋙ getText) ⤙ page + pages ← makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) ⤙ page - ( eelem "/" - += ( eelem "rdf:RDF" - += sattr "xmlns" "http://purl.org/rss/1.0/" - += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" - += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/" - += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/" - += ( eelem "channel" - += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "") - += ( eelem "title" - += txt siteName - += txt " - " - += getXPathTreesInDoc "/page/@name/text()" - ) - += ( eelem "link" - += txt (uriToString id baseURI "") - ) - += ( eelem "description" - += txt (case summary of - Nothing -> "RSS Feed for " ++ siteName - Just s -> s) - ) - += ( eelem "items" - += ( eelem "rdf:Seq" - += ( constL pages - >>> - eelem "rdf:li" - += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText) - ) - ) - ) - ) - += ( constL pages - >>> - arr (\ n -> (n, Nothing)) - >>> - getPageA (envStorage env) - >>> - arr fromJust - >>> - eelem "item" - += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText) - += ( eelem "title" - += (arr entityName >>> mkText) - ) - += ( eelem "link" - += (arr (mkPageURIStr baseURI . entityName) >>> mkText) - ) - += ( arrL (\ p -> case entitySummary p of - Nothing -> [] - Just s -> [s]) - >>> - eelem "description" - += mkText - ) - += ( eelem "dc:date" - += ( arrIO (utcToLocalZonedTime . entityLastMod) - >>> - arr W3C.format - >>> - mkText - ) - ) - += ( eelem "trackback:ping" - += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText) - ) - ) - >>> - uniqueNamespacesFromDeclAndQNames - ) ) -<< page + ( eelem "/" + += ( eelem "rdf:RDF" + += sattr "xmlns" "http://purl.org/rss/1.0/" + += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" + += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/" - += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/" + += ( eelem "channel" + += sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "") + += ( eelem "title" + += txt (T.unpack siteName) + += txt " - " + += getXPathTreesInDoc "/page/@name/text()" + ) + += ( eelem "link" + += txt (uriToString id baseURI "") + ) + += ( eelem "description" + += txt (case summary of + Nothing → "RSS Feed for " ⊕ T.unpack siteName + Just s → s) + ) + += ( eelem "items" + += ( eelem "rdf:Seq" + += ( constL pages + ⋙ + eelem "rdf:li" + += attr "resource" (arr (mkPageURIStr baseURI) ⋙ mkText) ) ) ) ) + += ( constL pages + ⋙ + arr (\n → (n, Nothing)) + ⋙ + getPageA (envStorage env) + ⋙ + arr fromJust + ⋙ + eelem "item" + += attr "rdf:about" (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText) + += ( eelem "title" + += (arr (T.unpack ∘ entityName) ⋙ mkText) + ) + += ( eelem "link" + += (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText) + ) + += ( arrL (\p → case entitySummary p of + Nothing → [] + Just s → [s]) + ⋙ + eelem "description" + += mkText + ) + += ( eelem "dc:date" + += ( arrIO (utcToLocalZonedTime . entityLastMod) + ⋙ - arr formatW3CDateTime ++ arr W3C.format + ⋙ + mkText + ) + ) - += ( eelem "trackback:ping" - += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) ⋙ mkText) - ) + ) + ⋙ + uniqueNamespacesFromDeclAndQNames + ) ) ⤛ page where - mkPageURIStr :: URI -> PageName -> String + mkPageURIStr :: URI → PageName → String mkPageURIStr baseURI name = uriToString id (mkPageURI baseURI name) "" - mkTrackbackURIStr :: URI → PageName → String - mkTrackbackURIStr :: URI -> PageName -> String -- mkTrackbackURIStr baseURI name -- = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) "" - -- -readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (PageName, Maybe XmlTree, PageName) XmlTree +readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → (PageName, Maybe XmlTree, PageName) ⇝ XmlTree readSubPage env - = proc (mainPageName, mainPage, subPageName) -> - do langM <- case mainPage of + = proc (mainPageName, mainPage, subPageName) → + do langM ← case mainPage of Nothing - -> returnA -< Nothing + → returnA ⤙ Nothing Just p - -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p - subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing) - localSubPage <- case langM of + → maybeA (getXPathTreesInDoc "/page/@lang/text()" ⋙ getText) ⤙ p + subPage ← getPageA (envStorage env) ⋙ arr fromJust ⤙ (subPageName, Nothing) + localSubPage ← case langM of Nothing - -> returnA -< subPage + → returnA ⤙ subPage Just l - -> localize (envStorage env) -< (l, subPage) - subPageXml <- xmlizePage -< localSubPage - subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) - -< (Just mainPageName, mainPage, subPageXml) - returnA -< subXHTML + → localize (envStorage env) ⤙ (CI.mk $ T.pack l, subPage) + subPageXml ← xmlizePage ⤙ localSubPage + subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) + ⤙ (Just mainPageName, mainPage, subPageXml) + returnA ⤙ subXHTML where - localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page + localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (LanguageTag, Page) ⇝ Page localize sto = proc (lang, origPage) - -> do let otherLang = entityOtherLang origPage - localName = M.lookup lang otherLang - case localName of - Nothing - -> returnA -< origPage - Just ln - -> do localPage <- getPageA sto -< (ln, Nothing) - returnA -< case localPage of - Nothing -> origPage - Just p -> p + → do let otherLang = entityOtherLang origPage + localName = M.lookup lang otherLang + case localName of + Nothing + → returnA ⤙ origPage + Just ln + → do localPage ← getPageA sto ⤙ (ln, Nothing) + returnA ⤙ case localPage of + Nothing → origPage + Just p → p {- diff --cc Rakka/Resource/Search.hs index 56f99c0,eb4acf2..2d076e8 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@@ -8,24 -2,14 +8,26 @@@ module Rakka.Resource.Searc ( 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 Data.List ++import qualified Data.ByteString.Char8 as C8 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 Prelude.Unicode import Rakka.Environment import Rakka.Page import Rakka.Resource @@@ -94,44 -77,44 +95,44 @@@ handleSearch en let to' = min (from + length (srPages result)) to - BaseURI baseURI <- getSysConf (envSysConf env) + BaseURI baseURI ← getSysConf (envSysConf env) 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 - mkCond :: String -> Maybe String -> Int -> Int -> IO Condition + mkCond ∷ Text → Maybe Text → Int → Int → IO Condition mkCond query order from to - = do cond <- newCondition + = do cond ← newCondition 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" - += attr "name" (arr hpPageName >>> mkText) - += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) - >>> + += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText) + += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod) + ⋙ - arr formatW3CDateTime + arr W3C.format - >>> + ⋙ mkText ) += ( arrL hpSnippet @@@ -289,13 -277,13 +290,13 @@@ searchResultToXHTML en += ( eelem "div" += sattr "class" "date" += ( getAttrValue "lastModified" - >>> + ⋙ - arr (zonedTimeToUTC . fromJust . parseW3CDateTime) + arr (zonedTimeToUTC . fromJust . W3C.parse) - >>> + ⋙ arrIO utcToLocalZonedTime - >>> + ⋙ arr RFC1123.format - >>> + ⋙ mkText ) ) @@@ -375,15 -363,15 +376,15 @@@ = 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 diff --cc Rakka/Resource/TrackBack.hs index df1f5c3,1bcdbf9..0000000 deleted file mode 100644,100644 --- a/Rakka/Resource/TrackBack.hs +++ /dev/null @@@ -1,154 -1,154 +1,0 @@@ --module Rakka.Resource.TrackBack -- ( resTrackBack -- ) -- where -- --import qualified Codec.Binary.UTF8.String as UTF8 --import Control.Arrow --import Control.Arrow.ArrowList --import Control.Monad.Trans --import Data.List --import Data.Maybe --import Data.Time --import Network.Browser --import Network.HTTP --import Network.HTTP.Lucu --import Network.HTTP.Lucu.Response --import Network.URI --import Rakka.Environment --import Rakka.Page --import Rakka.Storage --import Rakka.SystemConfig --import Rakka.TrackBack --import Text.XML.HXT.Arrow.WriteDocument --import Text.XML.HXT.Arrow.XmlArrow --import Text.XML.HXT.Arrow.XmlIOStateArrow --import Text.XML.HXT.DOM.TypeDefs --import Text.XML.HXT.DOM.XmlKeywords -- -- --data TBResponse -- = NoError -- | Error !Int !String -- deriving (Show, Eq) -- -- --resTrackBack :: Environment -> ResourceDef --resTrackBack env -- = ResourceDef { -- resUsesNativeThread = False -- , resIsGreedy = True -- , resGet = Nothing -- , resHead = Nothing -- , resPost = Just $ getPathInfo >>= handlePost env . toPageName -- , resPut = Nothing -- , resDelete = Nothing -- } -- where -- toPageName :: [String] -> PageName -- toPageName = UTF8.decodeString . joinPath -- -- --handlePost :: Environment -> PageName -> Resource () --handlePost env name -- = do form <- inputForm defaultLimit -- tbParamM <- validateTrackBack form -- case tbParamM of -- Nothing -- -> return () -- Just tbParam -- -> do cited <- liftIO $ checkCitation tbParam name -- if cited then -- do pageM <- getPage (envStorage env) name Nothing -- case pageM of -- Nothing -> setStatus NotFound -- Just page -> addTB tbParam page -- else -- outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.") -- where -- addTB :: TrackBack -> Page -> Resource () -- addTB tbParam page -- | isRedirect page -- = do BaseURI baseURI <- getSysConf (envSysConf env) -- redirect TemporaryRedirect (mkPageURI baseURI $ redirName page) -- | otherwise -- = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing -- st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM) -- if isSuccessful st then -- outputResponse NoError -- else -- setStatus st -- -- --validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack) --validateTrackBack form -- = do let title = get' "title" -- excerpt = get' "excerpt" -- blogName = get' "blog_name" -- case get' "url" of -- Nothing -- -> do outputResponse (Error 1 "Parameter `url' is missing.") -- return Nothing -- Just u -- -> case parseURI u of -- Nothing -- -> do outputResponse (Error 1 "Parameter `url' is malformed.") -- return Nothing -- Just url -- -> do time <- liftIO getCurrentTime -- return $ Just TrackBack { -- tbTitle = title -- , tbExcerpt = excerpt -- , tbURL = url -- , tbBlogName = blogName -- , tbTime = time -- } -- where -- get' :: String -> Maybe String -- get' = fmap UTF8.decodeString . flip lookup form -- -- --outputResponse :: TBResponse -> Resource () --outputResponse res -- = do setContentType $ read "text/xml" -- [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail -- >>> -- mkResponseTree -- >>> -- writeDocumentToString [ (a_indent , v_1 ) -- , (a_output_encoding, utf8) -- , (a_no_xml_pi , v_0 ) ] -- ) - output $ UTF8.encodeString xmlStr - output xmlStr -- where -- mkResponseTree :: ArrowXml a => a b XmlTree -- mkResponseTree -- = proc _ -- -> ( eelem "/" -- += ( eelem "response" -- += ( eelem "error" -- += txt (case res of -- NoError -> "0" -- Error code _ -> show code) -- ) -- += ( case res of -- NoError -> none -- Error _ msg -> ( eelem "message" -- += txt msg -- ) -- ) -- ) -- ) -< () -- -- --checkCitation :: TrackBack -> PageName -> IO Bool --checkCitation param name -- = do (_, res) <- browse $ -- do setAllowRedirects True -- setErrHandler (\ _ -> return ()) -- setOutHandler (\ _ -> return ()) -- request $ defaultGETRequest $ tbURL param -- case rspCode res of -- (2, 0, 0) -- -> return (encodePageName name `isInfixOf` rspBody res) -- _ -> return False diff --cc Rakka/Storage/Impl.hs index 8b3cbeb,304b817..55bda71 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@@ -19,12 -15,10 +19,13 @@@ import Control.Concurrent.ST import Control.Exception import Control.Monad import Data.Maybe +import Data.Monoid.Unicode import Data.Set (Set) import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T import Data.Time + import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI @@@ -213,34 -205,35 +213,34 @@@ searchIndex index con in (total, words) - fromId :: [String] -> DocumentID -> IO HitPage + fromId ∷ [Text] → DocumentID → IO HitPage fromId words docId - = do uri <- getDocURI index docId - rev <- unsafeInterleaveIO $ - liftM (read . fromJust) - (getDocAttr index docId "rakka:revision") - lastMod <- unsafeInterleaveIO $ - liftM (zonedTimeToUTC . fromJust . W3C.parse . fromJust) - (getDocAttr index docId "@mdate") - summary <- unsafeInterleaveIO $ - getDocAttr index docId "rakka:summary" - snippet <- unsafeInterleaveIO $ - do doc <- getDocument index docId [NoAttributes, NoKeywords] - sn <- makeSnippet doc words 300 80 80 - return (trim (== Boundary) $ map toFragment sn) - return HitPage { - hpPageName = decodePageName $ uriPath uri - , hpPageRev = rev - , hpLastMod = lastMod - , hpSummary = summary - , hpSnippet = snippet - } - - toFragment :: Either String (String, String) -> SnippetFragment - toFragment (Left "") = Boundary - toFragment (Left t) = NormalText t + = do uri ← getDocURI index docId + rev ← unsafeInterleaveIO $ + -- FIXME: use Data.Text.Read + read ∘ T.unpack ∘ fromJust + <$> getDocAttr index docId "rakka:revision" + lastMod ← unsafeInterleaveIO $ - zonedTimeToUTC ∘ fromJust ∘ parseW3CDateTime ∘ T.unpack ∘ fromJust ++ zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ T.unpack ∘ fromJust + <$> getDocAttr index docId "@mdate" + summary ← unsafeInterleaveIO $ + getDocAttr index docId "rakka:summary" + snippet ← unsafeInterleaveIO $ + do doc ← getDocument index docId [NoAttributes, NoKeywords] + sn ← makeSnippet doc words 300 80 80 + pure (trim (≡ Boundary) $ map toFragment sn) + pure HitPage { + hpPageName = decodePageName $ uriPath uri + , hpPageRev = rev + , hpLastMod = lastMod + , hpSummary = summary + , hpSnippet = snippet + } + toFragment ∷ Either Text (Text, Text) -> SnippetFragment + toFragment (Left "" ) = Boundary + toFragment (Left t ) = NormalText t toFragment (Right (w, _)) = HighlightedWord w - updateIndex :: Database -> Repository -> (Page -> IO Document) diff --cc Rakka/Storage/Repos.hs index 6a90ed6,ae4ce70..05759d9 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@@ -24,13 -14,11 +24,14 @@@ import qualified Data.CaseInsensitive a import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid.Unicode import Data.Set (Set) import qualified Data.Set as S hiding (Set) +import qualified Data.Text as T import Data.Time + import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu hiding (redirect) +import Prelude.Unicode import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig @@@ -203,10 -193,10 +203,10 @@@ loadPageInRepository repos name re content <- getFileContents path let pageRev = fst $ head hist - dest = chomp $ decodeString content + dest = T.pack ∘ chomp $ decodeString content lastMod <- unsafeIOToFS $ - liftM (fromJust . parseW3CDateTime . chomp . fromJust) + liftM (fromJust . W3C.parse . chomp . fromJust) (getRevisionProp' fs pageRev "svn:date") isLocked <- liftM isJust (getNodeProp path "rakka:isLocked") diff --cc Rakka/SystemConfig.hs index 029d307,c151427..d15bc9d --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@@ -230,9 -224,14 +230,14 @@@ instance SysConfValue BaseURI wher defaultValue sc = let conf = scLucuConf sc host = C8.unpack $ LC.cnfServerHost conf - port = unsafePerformIO ∘ getServicePortNumber $ LC.cnfServerPort conf + port = unsafePerformIO $ + do ent <- getServiceByName (LC.cnfServerPort conf) "tcp" + return (servicePort ent) + -- FIXME: There should be a way to change configurations + -- without web interface nor direct repository + -- modification. defaultURI - = "http://" ++ host ++ -- FIXME: consider IPv6 address - = "http://" ++ host ++ ++ = "http://" ++ host ++ (if port == 80 then "" else ':' : show port) ++ "/" diff --cc Rakka/TrackBack.hs index 8b1d2cb,8b1d2cb..0000000 deleted file mode 100644,100644 --- a/Rakka/TrackBack.hs +++ /dev/null @@@ -1,96 -1,96 +1,0 @@@ --module Rakka.TrackBack -- ( TrackBack(..) -- ) -- where -- --import Data.Maybe --import Data.Time --import Network.URI --import Rakka.Attachment --import Rakka.Utils --import Rakka.W3CDateTime --import Text.XML.HXT.Arrow --import Text.XML.HXT.DOM.TypeDefs -- -- --data TrackBack -- = TrackBack { -- tbTitle :: !(Maybe String) -- , tbExcerpt :: !(Maybe String) -- , tbURL :: !URI -- , tbBlogName :: !(Maybe String) -- , tbTime :: !UTCTime -- } -- deriving (Show, Eq) -- -- --{- -- -- -- excerpt... -- -- ... -- ---} --instance Attachment [TrackBack] where -- serializeToXmlTree -- = proc trackbacks -- -> ( eelem "/" -- += ( eelem "trackbacks" -- += ( arrL id -- >>> -- tbToTree -- ) -- ) -- ) -< trackbacks -- where -- tbToTree :: ArrowXml a => a TrackBack XmlTree -- tbToTree -- = proc tb -- -> let title = case tbTitle tb of -- Nothing -> none -- Just t -> sattr "title" t -- excerpt = case tbExcerpt tb of -- Nothing -> none -- Just e -> txt e -- url = sattr "url" (uriToString id (tbURL tb) "") -- blogName = case tbBlogName tb of -- Nothing -> none -- Just n -> sattr "blogName" n -- time = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb)) -- in -- ( eelem "trackback" -- += title -- += url -- += blogName -- += time -- += excerpt -- ) -<< () -- -- deserializeFromXmlTree -- = proc doc -> listA (getXPathTreesInDoc "/trackbacks/trackback" >>> treeToTb) -< doc -- where -- treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack -- treeToTb -- = proc tree -- -> do title <- maybeA (getAttrValue0 "title") -< tree -- url <- ( getAttrValue0 "url" -- >>> -- arr (fromJust . parseURI) -- ) -< tree -- time <- ( getAttrValue0 "time" -- >>> -- arr (zonedTimeToUTC . fromJust . parseW3CDateTime) -- ) -< tree -- blogName <- maybeA (getAttrValue0 "blogName") -< tree -- excerpt <- maybeA ( getChildren -- >>> -- getText -- ) -< tree -- returnA -< TrackBack { -- tbTitle = title -- , tbExcerpt = excerpt -- , tbURL = url -- , tbBlogName = blogName -- , tbTime = time -- } diff --cc Rakka/Utils.hs index 3148c6b,e89fee0..717a606 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@@ -16,18 -13,23 +16,24 @@@ module Rakka.Util , 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 Control.Arrow + import Control.Arrow.ArrowList -import Data.Ascii (Ascii) -import qualified Data.Ascii as A ++import Data.ByteString (ByteString) + import qualified Data.ByteString as BS + import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Unsafe as BS + import qualified Data.ByteString.Lazy as LS ++import qualified Data.ByteString.Unsafe as BS + import Data.Char -import qualified Data.Text as T +import Data.Monoid.Unicode +import Data.String - import Magic - import Network.HTTP.Lucu - import Network.URI ++import Data.Text (Text) + import Data.Text.Encoding + import Magic + import Network.HTTP.Lucu + import Network.URI + import Numeric import Prelude.Unicode - import System.IO.Unsafe + import System.IO.Unsafe yesOrNo ∷ Bool → String yesOrNo True = "yes" @@@ -37,58 -39,95 +43,91 @@@ trueOrFalse ∷ Bool → Strin trueOrFalse True = "true" trueOrFalse False = "false" -parseYesOrNo ∷ ArrowChoice a ⇒ a String Bool -parseYesOrNo - = proc str → do case str of - "yes" → returnA ⤙ True - "no" → returnA ⤙ False - _ → returnA ⤙ error ("Expected yes or no: " ⧺ str) +parseYesOrNo ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool - parseYesOrNo - = proc str → - case str of - _ | str ≡ "yes" → returnA ⤙ True - | str ≡ "no" → returnA ⤙ False - | otherwise → returnA ⤙ error ("Expected yes or no: " ⊕ show str) ++parseYesOrNo = arr f ++ where ++ f "yes" = True ++ f "no" = False ++ f str = error ("Expected yes or no: " ⊕ show str) - maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c) + maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c) maybeA a = listA a >>> - proc xs -> case xs of - [] -> returnA -< Nothing - (x:_) -> returnA -< Just x - + proc xs → case xs of + [] → returnA ⤙ Nothing + (x:_) → returnA ⤙ Just x - deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String + deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String deleteIfEmpty - = proc str -> do case str of - "" -> none -< () - _ -> returnA -< str - + = proc str → do case str of + "" → none ⤙ () + _ → returnA ⤙ str - chomp :: String -> String - chomp = reverse . snd . break (/= '\n') . reverse + chomp ∷ String → String + {-# INLINE chomp #-} + chomp = reverse . snd . break (≢ '\n') . reverse - - guessMIMEType :: Lazy.ByteString -> MIMEType - guessMIMEType = read . unsafePerformIO . magicString magic . L8.unpack + guessMIMEType ∷ LS.ByteString → MIMEType + {-# INLINEABLE guessMIMEType #-} + guessMIMEType = read + ∘ unsafePerformIO + ∘ flip BS.unsafeUseAsCStringLen (magicCString magic) + ∘ BS.concat + ∘ LS.toChunks where - magic :: Magic + magic ∷ Magic + {-# NOINLINE magic #-} magic = unsafePerformIO - $ do m <- magicOpen [MagicMime] + $ do m ← magicOpen [MagicMime] magicLoadDefault m return m - - isSafeChar :: Char -> Bool -{- + isSafeChar ∷ Char → Bool + {-# INLINEABLE isSafeChar #-} isSafeChar c - | c == '/' = True - | isReserved c = False - | c > ' ' && c <= '~' = True - | otherwise = False + | c ≡ '/' = True + | isReserved c = False + | c > ' ' ∧ c ≤ '~' = True + | otherwise = False --} -mkQueryString ∷ [(T.Text, T.Text)] → Ascii ++mkQueryString ∷ [(Text, Text)] → ByteString + {-# INLINEABLE mkQueryString #-} -mkQueryString = A.unsafeFromByteString - ∘ BS.intercalate (C8.singleton ';') - ∘ map encodePair ++mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair + where - encodePair ∷ (T.Text, T.Text) → BS.ByteString ++ encodePair ∷ (Text, Text) → ByteString + {-# INLINE encodePair #-} + encodePair (k, v) + = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v] + - encodeText ∷ T.Text → BS.ByteString ++ encodeText ∷ Text → ByteString + {-# INLINE encodeText #-} + encodeText = toURLEncoded ∘ encodeUtf8 - mkQueryString :: [(String, String)] -> String - mkQueryString [] = "" - mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++ - if xs == [] then - "" - else - ';' : mkQueryString(xs) -toURLEncoded ∷ BS.ByteString → BS.ByteString ++toURLEncoded ∷ ByteString → ByteString + {-# INLINEABLE toURLEncoded #-} + toURLEncoded = C8.concatMap go where - encode :: String -> String - encode = escapeURIString isSafeChar . UTF8.encodeString - go ∷ Char → BS.ByteString ++ go ∷ Char → ByteString + {-# INLINE go #-} + go c | c ≡ ' ' = C8.singleton '+' + | isReserved c = urlEncode c + | isUnreserved c = C8.singleton c + | otherwise = urlEncode c + - urlEncode ∷ Char → BS.ByteString ++ urlEncode ∷ Char → ByteString + {-# INLINE urlEncode #-} + urlEncode c = C8.pack ('%':toHex (ord c)) + + toHex ∷ Int → String + {-# INLINE toHex #-} + toHex n + = case showIntAtBase 16 toChrHex n "" of + [] → "00" + [c] → ['0', c] + cs → cs + + toChrHex ∷ Int → Char + {-# INLINE toChrHex #-} + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d ) + | otherwise = chr (ord 'A' + fromIntegral (d-10)) diff --cc Rakka/Wiki/Interpreter/PageList.hs index d94f67e,2fe9d30..4faee0f --- a/Rakka/Wiki/Interpreter/PageList.hs +++ b/Rakka/Wiki/Interpreter/PageList.hs @@@ -7,11 -2,9 +7,12 @@@ module Rakka.Wiki.Interpreter.PageLis ( interpreters ) where - -import Control.Monad -import Data.Maybe +import Control.Applicative +import Control.Monad ++import qualified Data.ByteString.Char8 as C8 +import Data.Maybe +import Data.Monoid.Unicode +import qualified Data.Text as T import Data.Time import qualified Data.Time.RFC1123 as RFC1123 import Network.URI @@@ -39,9 -31,9 +40,9 @@@ recentUpdatesURLInter = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) let uri = baseURI { uriPath = uriPath baseURI "search.html" -- , uriQuery = '?' : mkQueryString [ ("q" , "[UVSET]") -- , ("order", "@mdate NUMD") -- ] ++ , uriQuery = '?' : C8.unpack (mkQueryString [ ("q" , "[UVSET]") ++ , ("order", "@mdate NUMD") ++ ]) } return $ ExternalLink uri (Just "List all pages") } diff --cc Rakka/Wiki/Interpreter/Trackback.hs index b5e5cf0,b5e5cf0..0000000 deleted file mode 100644,100644 --- a/Rakka/Wiki/Interpreter/Trackback.hs +++ /dev/null @@@ -1,75 -1,75 +1,0 @@@ --module Rakka.Wiki.Interpreter.Trackback -- ( interpreters -- ) -- where -- --import Data.Maybe --import Data.Time --import Network.HTTP.Lucu.RFC1123DateTime --import Rakka.Page --import Rakka.Storage --import Rakka.SystemConfig --import Rakka.TrackBack --import Rakka.Wiki --import Rakka.Wiki.Interpreter -- -- --interpreters :: [Interpreter] --interpreters = [ trackbackURLInterp -- , trackbacksInterp -- ] -- -- --trackbackURLInterp :: Interpreter --trackbackURLInterp -- = InlineCommandInterpreter { -- iciName = "trackbackURL" -- , iciInterpret -- = \ ctx _ -> case ctxPageName ctx of -- Nothing -- -> return (Text "No trackbacks for this page.") -- Just name -- -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) -- let uri = mkAuxiliaryURI baseURI ["trackback"] name -- return $ ExternalLink uri (Just "Trackback URL") -- } -- -- --trackbacksInterp :: Interpreter --trackbacksInterp -- = BlockCommandInterpreter { -- bciName = "trackbacks" -- , bciInterpret -- = \ ctx _ -> -- do trackbacks <- case ctxPageName ctx of -- Nothing -- -> return [] -- Just name -- -> liftM (fromMaybe []) -- (getAttachment (ctxStorage ctx) name "trackbacks" Nothing) -- items <- mapM mkListItem trackbacks -- -- let divElem = Div [("class", "trackbacks")] [list] -- list = Block (List Bullet items) -- -- return divElem -- } -- where -- mkListItem :: TrackBack -> IO ListItem -- mkListItem tb -- = do zonedTime <- utcToLocalZonedTime (tbTime tb) -- -- let anchor = Just (Inline (ExternalLink (tbURL tb) label)) -- label = case (tbTitle tb, tbBlogName tb) of -- (Nothing , Nothing ) -> Nothing -- (Just title, Nothing ) -> Just title -- (Nothing , Just blogName) -> Just blogName -- (Just title, Just blogName) -> Just (title ++ " (" ++ blogName ++ ")") -- date = Just ( Block ( Div [("class", "date")] -- [Inline (Text (formatRFC1123DateTime zonedTime))] -- ) -- ) -- excerpt = do e <- tbExcerpt tb -- return $ Block $ Paragraph [Text e] -- -- return $ catMaybes [anchor, date, excerpt] diff --cc defaultPages/StyleSheet/CieloNegro.xml index 6e41dda,6e41dda..ec8152f --- a/defaultPages/StyleSheet/CieloNegro.xml +++ b/defaultPages/StyleSheet/CieloNegro.xml @@@ -422,8 -422,8 +422,7 @@@ input[type="button"][disabled]:active text-indent: 0; } --.sideBar .recentUpdates p, --.sideBar .trackbacks p { ++.sideBar .recentUpdates p { font-size: 90%; } diff --cc defaultPages/StyleSheet/Default.xml index 499bf03,499bf03..49c3e6e --- a/defaultPages/StyleSheet/Default.xml +++ b/defaultPages/StyleSheet/Default.xml @@@ -392,8 -392,8 +392,7 @@@ input[type="button"][disabled]:active text-indent: 0; } --.sideBar .recentUpdates p, --.sideBar .trackbacks p { ++.sideBar .recentUpdates p { font-size: 90%; } @@@ -422,7 -422,7 +421,7 @@@ -moz-border-radius: 10px; } --.sideBar .recentUpdates li, .sideBar .trackbacks li { ++.sideBar .recentUpdates li { background-color: #e0e0e0; }