From b3c3f333cd48bc74eb33f0f21d56a9d1bc65e0ea Mon Sep 17 00:00:00 2001 From: pho Date: Mon, 22 Oct 2007 17:05:11 +0900 Subject: [PATCH] wrote many darcs-hash:20071022080511-62b54-0bf17a94e178d0cc2db27c0d878ede6971af358d.gz --- Rakka/Resource/Render.hs | 301 ++++++++++++++++++++++---------- Rakka/Wiki.hs | 5 + Rakka/Wiki/Engine.hs | 30 ++-- Rakka/Wiki/Formatter.hs | 15 ++ Rakka/Wiki/Interpreter.hs | 16 +- Rakka/Wiki/Interpreter/Base.hs | 5 +- Rakka/Wiki/Parser.hs | 16 ++ defaultPages/Help/Syntax | 14 +- defaultPages/MainPage | 6 +- defaultPages/StyleSheet/Default | 51 +++--- tests/WikiParserTest.hs | 14 ++ 11 files changed, 321 insertions(+), 152 deletions(-) diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 27671da..df141b1 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -51,7 +51,7 @@ handleGet env name -> do pageM <- getPageA (envStorage env) -< name case pageM of Nothing - -> returnA -< foundNoEntity Nothing + -> handlePageNotFound env -< name Just redir@(Redirection _ _ _ _) -> handleRedirect env -< redir @@ -79,7 +79,7 @@ handleRedirect env isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" revision="112"> -- デフォルトでない場合のみ存在 - lastModified="2000-01-01T00:00:00" /> + lastModified="2000-01-01T00:00:00"> blah blah... @@ -109,94 +109,95 @@ handleRedirect env -} handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) handleGetEntity env - = let sysConf = envSysConf env - in - proc page - -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () - BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () - StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () - - Just pageTitle <- getPageA (envStorage env) -< "PageTitle" - Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left" - Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right" - - tree <- ( eelem "/" - += ( eelem "page" - += sattr "site" siteName - += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") - += sattr "name" (pageName page) - += sattr "type" (show $ pageType page) - += ( case pageType page of - MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ pageIsTheme page) - _ -> none - ) - += ( case pageType page of - MIMEType "text" "x-rakka" _ - -> sattr "isFeed" (yesOrNo $ pageIsFeed page) - _ -> none - ) - += sattr "isLocked" (yesOrNo $ pageIsLocked page) - += ( case pageRevision page of - Nothing -> none - Just rev -> sattr "revision" (show rev) - ) - += sattr "lastModified" (formatW3CDateTime $ pageLastMod page) - - += ( case pageSummary page of - Nothing -> none - Just s -> eelem "summary" += txt s - ) - - += ( case pageOtherLang page of - [] -> none - xs -> selem "otherLang" - [ eelem "link" - += sattr "lang" lang - += sattr "page" page - | (lang, page) <- xs ] - ) - += ( eelem "pageTitle" - += ( (constA page &&& constA pageTitle) - >>> - formatSubPage env - ) - ) - += ( eelem "sideBar" - += ( eelem "left" - += ( (constA page &&& constA leftSideBar) - >>> - formatSubPage env - ) - ) - += ( eelem "right" - += ( (constA page &&& constA rightSideBar) - >>> - formatSubPage env - ) - ) - ) - += ( eelem "body" - += (constA page >>> formatPage env) - ) - >>> - uniqueNamespacesFromDeclAndQNames - ) - ) -<< () - - returnA -< do let lastMod = toClockTime $ pageLastMod page - - -- text/x-rakka の場合は、内容が動的に生 - -- 成されてゐる可能性があるので、ETag も - -- Last-Modified も返す事が出來ない。 - case pageType page of + = proc page + -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () + BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () + StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () + + Just pageTitle <- getPageA (envStorage env) -< "PageTitle" + Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left" + Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right" + + tree <- ( eelem "/" + += ( eelem "page" + += sattr "site" siteName + += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") + += sattr "name" (pageName page) + += sattr "type" (show $ pageType page) + += ( case pageType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + _ -> none + ) + += ( case pageType page of MIMEType "text" "x-rakka" _ - -> return () - _ -> case pageRevision page of - Nothing -> foundTimeStamp lastMod - Just rev -> foundEntity (strongETag $ show rev) lastMod + -> sattr "isFeed" (yesOrNo $ pageIsFeed page) + _ -> none + ) + += sattr "isLocked" (yesOrNo $ pageIsLocked page) + += ( case pageRevision page of + Nothing -> none + Just rev -> sattr "revision" (show rev) + ) + += sattr "lastModified" (formatW3CDateTime $ pageLastMod page) + + += ( case pageSummary page of + Nothing -> none + Just s -> eelem "summary" += txt s + ) + + += ( case pageOtherLang page of + [] -> none + xs -> selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" page + | (lang, page) <- xs ] + ) + += ( eelem "pageTitle" + += ( (constA (pageName page) &&& constA pageTitle) + >>> + formatSubPage env + ) + ) + += ( eelem "sideBar" + += ( eelem "left" + += ( (constA (pageName page) &&& constA leftSideBar) + >>> + formatSubPage env + ) + ) + += ( eelem "right" + += ( (constA (pageName page) &&& constA rightSideBar) + >>> + formatSubPage env + ) + ) + ) + += ( eelem "body" + += (constA page >>> formatPage env) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) + ) -<< () - outputXmlPage tree entityToXHTML + returnA -< do let lastMod = toClockTime $ pageLastMod page + + -- text/x-rakka の場合は、内容が動的に生成され + -- てゐる可能性があるので、ETag も + -- Last-Modified も返す事が出來ない。 + case pageType page of + MIMEType "text" "x-rakka" _ + -> return () + _ -> case pageRevision page of + Nothing -> foundTimeStamp lastMod + Just rev -> foundEntity (strongETag $ show rev) lastMod + + outputXmlPage tree entityToXHTML + where + sysConf :: SystemConfig + sysConf = envSysConf env entityToXHTML :: ArrowXml a => a XmlTree XmlTree @@ -253,3 +254,127 @@ entityToXHTML >>> uniqueNamespacesFromDeclAndQNames ) + + +{- + + + + blah blah... + + + + + blah blah... + + + blah blah... + + + +-} +handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ()) +handlePageNotFound env + = proc name + -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () + BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () + StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () + + Just pageTitle <- getPageA (envStorage env) -< "PageTitle" + Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left" + Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right" + + tree <- ( eelem "/" + += ( eelem "pageNotFound" + += sattr "site" siteName + += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") + += sattr "name" name + + += ( eelem "pageTitle" + += ( (constA name &&& constA pageTitle) + >>> + formatSubPage env + ) + ) + += ( eelem "sideBar" + += ( eelem "left" + += ( (constA name &&& constA leftSideBar) + >>> + formatSubPage env + ) + ) + += ( eelem "right" + += ( (constA name &&& constA rightSideBar) + >>> + formatSubPage env + ) + ) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) + ) -<< () + + returnA -< do setStatus NotFound + outputXmlPage tree notFoundToXHTML + where + sysConf :: SystemConfig + sysConf = envSysConf env + + +notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree +notFoundToXHTML + = eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += getXPathTreesInDoc "/pageNotFound/@site/text()" + += txt " - " + += getXPathTreesInDoc "/pageNotFound/@name/text()" + ) + += ( eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" + ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" ) + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += getXPathTreesInDoc "/pageNotFound/pageTitle/*" + ) + += ( eelem "div" + += sattr "class" "body" + += txt "404 Not Found (FIXME)" -- FIXME + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += getXPathTreesInDoc "/pageNotFound/sideBar/left/*" + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += getXPathTreesInDoc "/pageNotFound/sideBar/right/*" + ) + ) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index 96231a4..f8341ec 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -17,6 +17,7 @@ module Rakka.Wiki where import Data.Generics +import Network.URI import Rakka.Page @@ -47,6 +48,10 @@ data InlineElement , linkFragment :: !(Maybe String) , linkText :: !(Maybe String) } + | ExternalLink { + extLinkURI :: !URI + , extLinkText :: !(Maybe String) + } | LineBreak ![Attribute] | Span ![Attribute] ![InlineElement] | Image ![Attribute] diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index f0de8fb..aa897e8 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -32,27 +32,27 @@ formatPage env -> do tree <- case pageType page of MIMEType "text" "x-rakka" _ -> do let source = decodeLazy UTF8 (pageContent page) - formatWikiPage env -< (Just page, source) + formatWikiPage env -< (pageName page, source) attachXHtmlNs -< tree formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (Page, Page) XmlTree + -> a (PageName, Page) XmlTree formatSubPage env - = proc (mainPage, subPage) + = proc (mainPageName, subPage) -> do tree <- case pageType subPage of MIMEType "text" "x-rakka" _ -> do let source = decodeLazy UTF8 (pageContent subPage) - formatWikiPage env -< (Just mainPage, source) + formatWikiPage env -< (mainPageName, source) attachXHtmlNs -< tree formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (Maybe Page, String) XmlTree + -> a (PageName, String) XmlTree formatWikiPage env - = proc (page, source) + = proc (name, source) -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () interpTable <- getInterpTableA env -< () @@ -63,7 +63,7 @@ formatWikiPage env -> formatParseError -< err Right blocks - -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks)) + -> do xs <- interpretCommandsA env -< (interpTable, (name, blocks)) formatWikiBlocks -< (baseURI, xs) where tableToFunc :: InterpTable -> String -> Maybe CommandType @@ -73,23 +73,23 @@ formatWikiPage env interpretCommandsA :: ArrowIO a => Environment - -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage + -> a (InterpTable, (PageName, WikiPage)) WikiPage interpretCommandsA = arrIO3 . interpretCommands -interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage +interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage interpretCommands _ _ _ [] = return [] -interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) blocks +interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks >>= everywhereM' (mkM interpInlineCmd) where ctx :: InterpreterContext ctx = InterpreterContext { - ctxPage = page - , ctxTree = blocks - , ctxStorage = envStorage env - , ctxSysConf = envSysConf env - } + ctxPageName = name + , ctxTree = blocks + , ctxStorage = envStorage env + , ctxSysConf = envSysConf env + } interpBlockCmd :: BlockElement -> IO BlockElement interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 7a7efce..a08fe30 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -164,6 +164,9 @@ formatInline link@(PageLink _ _ _) -> formatPageLink -< (baseURI, link) + link@(ExternalLink _ _) + -> formatExternalLink -< link + LineBreak attrs -> formatElem "br" -< (baseURI, attrs, []) @@ -214,3 +217,15 @@ formatPageLink += attr "href" (arr fst >>> mkText) += (arr snd >>> mkText) ) -< (href, label) + + +formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree +formatExternalLink + = proc (ExternalLink uri text) + -> let href = uriToString id uri "" + label = fromMaybe href text + in + ( eelem "a" + += attr "href" (arr fst >>> mkText) + += (arr snd >>> mkText) + ) -< (href, label) diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs index 09f7414..2a830b3 100644 --- a/Rakka/Wiki/Interpreter.hs +++ b/Rakka/Wiki/Interpreter.hs @@ -15,21 +15,21 @@ import Rakka.Wiki data Interpreter = InlineCommandInterpreter { - iciName :: String - , iciInterpret :: InterpreterContext -> InlineCommand -> IO InlineElement + iciName :: !String + , iciInterpret :: !(InterpreterContext -> InlineCommand -> IO InlineElement) } | BlockCommandInterpreter { - bciName :: String - , bciInterpret :: InterpreterContext -> BlockCommand -> IO BlockElement + bciName :: !String + , bciInterpret :: !(InterpreterContext -> BlockCommand -> IO BlockElement) } data InterpreterContext = InterpreterContext { - ctxPage :: Maybe Page - , ctxTree :: WikiPage - , ctxStorage :: Storage - , ctxSysConf :: SystemConfig + ctxPageName :: !PageName + , ctxTree :: !WikiPage + , ctxStorage :: !Storage + , ctxSysConf :: !SystemConfig } diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index fa225e6..c749589 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -3,7 +3,6 @@ module Rakka.Wiki.Interpreter.Base ) where -import Rakka.Page import Rakka.Wiki import Rakka.Wiki.Interpreter import Rakka.Wiki.Interpreter.Base.Image @@ -48,7 +47,5 @@ pageNameInterp :: Interpreter pageNameInterp = InlineCommandInterpreter { iciName = "pageName" , iciInterpret - = \ ctx (InlineCommand _ _ _) -> case ctxPage ctx of - Nothing -> return $ Text "(None)" - Just page -> return $ Text $ pageName page + = \ ctx _ -> return $ Text (ctxPageName ctx) } \ No newline at end of file diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index 0433612..e2e3926 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -5,6 +5,7 @@ module Rakka.Wiki.Parser where import Data.Maybe +import Network.URI import Rakka.Wiki import Text.ParserCombinators.Parsec @@ -267,6 +268,7 @@ inlineElement cmdTypeOf , apostrophes cmdTypeOf , text , pageLink + , extLink , inlineCmd cmdTypeOf ] @@ -345,6 +347,20 @@ pageLink = do try (string "[[") "page link" +extLink :: Parser InlineElement +extLink = do char '[' + uriStr <- many1 (noneOf " \t]") + skipMany (oneOf " \t") + text <- option Nothing + (many1 (noneOf "]") >>= return . Just) + + case parseURI uriStr of + Just uri -> char ']' >> return (ExternalLink uri text) + Nothing -> pzero "absolute URI" + + "external link" + + inlineCmd :: CommandTypeOf -> Parser InlineElement inlineCmd cmdTypeOf = (try $ do (tagName, tagAttrs) <- openTag diff --git a/defaultPages/Help/Syntax b/defaultPages/Help/Syntax index bc3e47e..41cbe04 100644 --- a/defaultPages/Help/Syntax +++ b/defaultPages/Help/Syntax @@ -49,18 +49,15 @@ but the text is reformatted. == Horizontal Line == ---- -== Inline Object == - - This is a caption containing [[Foo|markups]]. - - blah blah blah... + == Listing == * foo @@ -90,15 +87,12 @@ blah blah blah blah... * [[#Heading]] * [[Page#Heading|Link to "Page#Heading"]] * [[#example]] -* http://www.google.com/ -* [http://www.google.com Google] +* [http://www.google.com/] +* [http://www.google.com/ Google]
example
-== Reference == -Blah blah blah blah...Qwerty qwerty qwerty. - ]]> diff --git a/defaultPages/MainPage b/defaultPages/MainPage index d042a31..4c056fa 100644 --- a/defaultPages/MainPage +++ b/defaultPages/MainPage @@ -17,8 +17,8 @@ Another paragraph... == Subsection == -=== h3 === -==== h4 ==== -===== h5 ===== +* [[Help/Syntax]] +* [http://cielonegro.org/] +* [http://cielonegro.org/ CieloNegro] ]]> diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default index 584a8b7..bd566ef 100644 --- a/defaultPages/StyleSheet/Default +++ b/defaultPages/StyleSheet/Default @@ -71,6 +71,10 @@ padding: 25px 30px; } +.body h1, .body h2, .body h3, .body h4, .body h5, .body h6 { + margin: 5px 0px; +} + .body ul, .body ol { list-style-position: inside; margin: 1em 0; @@ -142,26 +146,24 @@ h1, h2, h3, h4, h5, h6 { font-weight: normal; } +hr { + border-color: #bbbbbb; + border-width: 1px; + border-style: dashed; +} + .title { background-color: #fafafa; border-color: #cccccc; - border-width: 0 0 3px 0; - border-style: double; + border-width: 0 0 1px 0; + border-style: solid; font-size: 1.2em; } .body h1 { - font-size: 180%; - - background-color: #fafafa; - - border-color: #dddddd; - border-width: 2px; - border-style: solid; - - padding: 0 10px; + font-size: 200%; } .body h2 { font-size: 150%; @@ -175,23 +177,32 @@ h1, h2, h3, h4, h5, h6 { .body h5 { font-size: 90%; } -.body h2, .body h3, .body h4, .body h5 { +.body h1, .body h2, .body h3, .body h4, .body h5 { background-color: #fafafa; border-color: #dddddd; - border-width: 0 0 1px 0; + border-width: 1px; border-style: solid; padding: 0 10px; } +a { + color: #008800; + text-decoration: none; +} + .header, .footer, .sideBar { background-color: #eeeeee; } .sideBar h1 { font-size: 120%; - font-weight: bold; +} +.sideBar h1, .sideBar h2, .sideBar h3, .sideBar h4, .sideBar h5 { + font-weight: normal; + + color: #555555; background-color: #fafafa; border-color: #dddddd white white #dddddd; @@ -199,14 +210,6 @@ h1, h2, h3, h4, h5, h6 { border-style: solid; } -.sideBar a { - color: #4e8eff; -} - -.sideBar a:visited { - color: #3f73d0; -} - .sideBar .date { font-size: 70%; white-space: nowrap; @@ -231,7 +234,7 @@ h1, h2, h3, h4, h5, h6 { } p { - margin: 0.8em 0; + margin: 0 0 0.8em 0; } /* float */ @@ -268,7 +271,7 @@ img { border-style: solid; margin-top: 5px; - margin-bottom: 5px; + margin-bottom: 10px; } .imageFrame p { diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs index 9bfdc4e..4b47e26 100644 --- a/tests/WikiParserTest.hs +++ b/tests/WikiParserTest.hs @@ -3,6 +3,8 @@ module WikiParserTest ) where +import Data.Maybe +import Network.URI import Rakka.Wiki import Rakka.Wiki.Parser import Test.HUnit @@ -340,4 +342,16 @@ testData = [ (parseWiki "" (Right [ Paragraph [Text "foo"] , BlockCmd (BlockCommand "div" [("id", "bar")] []) ])) + + , (parseWiki "[http://example.org/]" + ~?= + (Right [ Paragraph [ExternalLink (fromJust $ parseURI "http://example.org/") Nothing] ])) + + , (parseWiki "[http://example.org/ example.org]" + ~?= + (Right [ Paragraph [ExternalLink + (fromJust $ parseURI "http://example.org/") + (Just "example.org") + ] + ])) ] -- 2.40.0