-> do pageM <- getPageA (envStorage env) -< name
case pageM of
Nothing
- -> returnA -< foundNoEntity Nothing
+ -> handlePageNotFound env -< name
Just redir@(Redirection _ _ _ _)
-> handleRedirect env -< redir
isFeed="no" -- text/x-rakka の場合のみ存在
isLocked="no"
revision="112"> -- デフォルトでない場合のみ存在
- lastModified="2000-01-01T00:00:00" />
+ lastModified="2000-01-01T00:00:00">
<summary>
blah blah...
-}
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
>>>
uniqueNamespacesFromDeclAndQNames
)
+
+
+{-
+ <pageNotFound site="CieloNegro"
+ styleSheet="http://example.org/object/StyleSheet/Default"
+ name="Foo/Bar">
+
+ <pageTitle>
+ blah blah...
+ </pageTitle>
+
+ <sideBar>
+ <left>
+ blah blah...
+ </left>
+ <right>
+ blah blah...
+ </right>
+ </sideBar>
+ </pageNotFound>
+-}
+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
+ )
where
import Data.Generics
+import Network.URI
import Rakka.Page
, linkFragment :: !(Maybe String)
, linkText :: !(Maybe String)
}
+ | ExternalLink {
+ extLinkURI :: !URI
+ , extLinkText :: !(Maybe String)
+ }
| LineBreak ![Attribute]
| Span ![Attribute] ![InlineElement]
| Image ![Attribute]
-> 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 -< ()
-> 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
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
link@(PageLink _ _ _)
-> formatPageLink -< (baseURI, link)
+ link@(ExternalLink _ _)
+ -> formatExternalLink -< link
+
LineBreak attrs
-> formatElem "br" -< (baseURI, attrs, [])
+= 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)
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
}
)
where
-import Rakka.Page
import Rakka.Wiki
import Rakka.Wiki.Interpreter
import Rakka.Wiki.Interpreter.Base.Image
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
where
import Data.Maybe
+import Network.URI
import Rakka.Wiki
import Text.ParserCombinators.Parsec
, apostrophes cmdTypeOf
, text
, pageLink
+ , extLink
, inlineCmd cmdTypeOf
]
"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
== Horizontal Line ==
----
-== Inline Object ==
-<object data="Foo" float="right" inside="caption">
- This is a caption containing [[Foo|markups]].
-</object>
-
blah blah blah...
+<!--
== Quotation ==
<blockquote>
blah blah blah...
blah blah blah blah...
<cite>-- John Doe<cite>
+-->
== Listing ==
* foo
* [[#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]
<div id="example">example</div>
-== Reference ==
-Blah blah blah blah...<ref>Qwerty qwerty qwerty.</ref>
-
]]>
</textData>
</page>
== Subsection ==
-=== h3 ===
-==== h4 ====
-===== h5 =====
+* [[Help/Syntax]]
+* [http://cielonegro.org/]
+* [http://cielonegro.org/ CieloNegro]
]]></textData>
</page>
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;
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%;
.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;
border-style: solid;
}
-.sideBar a {
- color: #4e8eff;
-}
-
-.sideBar a:visited {
- color: #3f73d0;
-}
-
.sideBar .date {
font-size: 70%;
white-space: nowrap;
}
p {
- margin: 0.8em 0;
+ margin: 0 0 0.8em 0;
}
/* float */
border-style: solid;
margin-top: 5px;
- margin-bottom: 5px;
+ margin-bottom: 10px;
}
.imageFrame p {
)
where
+import Data.Maybe
+import Network.URI
import Rakka.Wiki
import Rakka.Wiki.Parser
import Test.HUnit
(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")
+ ]
+ ]))
]
projects / Rakka.git / commitdiff