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
, (["search.html" ], resSearch env)
, (["search.xml" ], resSearch env)
, (["systemConfig"], resSystemConfig env)
-- -- , (["trackback" ], resTrackBack env)
, (["users" ], resUsers env)
]
Executable rakka
Build-Depends:
- ascii == 0.0.*,
- base == 4.3.*,
+ HsHyperEstraier == 0.4.*,
++ HsOpenSSL == 0.10.*,
+ HsSVN == 0.4.*,
+ Lucu == 0.7.*,
++ 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
, 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 ]
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
}
deriving (Show, Eq)
--
data UpdateInfo
= UpdateInfo {
uiOldRevision :: !RevNum
-> 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
, 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 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
- }
+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)
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
]
-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
{-
( 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
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
+= ( eelem "div"
+= sattr "class" "date"
+= ( getAttrValue "lastModified"
- >>>
+ ⋙
- arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+ arr (zonedTimeToUTC . fromJust . W3C.parse)
- >>>
+ ⋙
arrIO utcToLocalZonedTime
- >>>
+ ⋙
arr RFC1123.format
- >>>
+ ⋙
mkText
)
)
= 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
+++ /dev/null
--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
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
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)
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
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")
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) ++ "/"
+++ /dev/null
--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)
--
--
--{-
-- <trackbacks>
-- <trackback title="" url="" blogName="" time="">
-- excerpt...
-- </trackback>
-- ...
-- </trackbacks>
---}
--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
-- }
, 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"
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))
( 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
= \ 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")
}
+++ /dev/null
--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]
text-indent: 0;
}
--.sideBar .recentUpdates p,
--.sideBar .trackbacks p {
++.sideBar .recentUpdates p {
font-size: 90%;
}
text-indent: 0;
}
--.sideBar .recentUpdates p,
--.sideBar .trackbacks p {
++.sideBar .recentUpdates p {
font-size: 90%;
}
-moz-border-radius: 10px;
}
--.sideBar .recentUpdates li, .sideBar .trackbacks li {
++.sideBar .recentUpdates li {
background-color: #e0e0e0;
}
projects / Rakka.git / commitdiff