import Rakka.Environment
import Rakka.Resource.Index
import Rakka.Resource.Object
-import Rakka.Resource.Page
+import Rakka.Resource.Render
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Posix.Types
import System.Posix.User
+
data CmdOpt
= OptPortNum PortNumber
| OptLSDir FilePath
setUserID uid
env <- setupEnv lsdir portNum
- runHttpd (envLucuConf env) (resTree env) [fallbackPage env]
+ runHttpd (envLucuConf env) (resTree env) [fallbackRender env]
resTree :: Environment -> ResTree
GHC-Options:
-fwarn-unused-imports
Build-Depends:
- base, mtl, network, unix, encoding, Crypto, hxt, filepath, HsSVN, Lucu
+ Crypto, HsSVN, Lucu, base, encoding, filepath, hxt, mtl, network, parsec, unix
Exposed-Modules:
Rakka.Page
Rakka.Storage
Rakka.SystemConfig
+ Rakka.Wiki
Other-Modules:
Rakka.Environment
Rakka.Storage.DefaultPage
Rakka.Utils
+ Rakka.Wiki.Engine
+ Rakka.Wiki.Formatter
+ Rakka.Wiki.Parser
Data-Files:
defaultPages/Main_Page
schemas/rakka-page-1.0.rng
}
where
toPageName :: [String] -> PageName
- toPageName = decodePageName . dropExtension . joinWith "/"
+ toPageName = decodePageName . joinWith "/"
handleGet :: Environment -> PageName -> Resource ()
+++ /dev/null
-module Rakka.Resource.Page
- ( fallbackPage
- )
- where
-
-import Data.Char
-import Network.HTTP.Lucu
-import Network.HTTP.Lucu.Utils
-import Rakka.Environment
-import Rakka.Page
-import Rakka.Resource.Page.Get
-import System.FilePath
-
-
-fallbackPage :: Environment -> [String] -> IO (Maybe ResourceDef)
-fallbackPage env path
- | null path = return Nothing
- | null $ head path = return Nothing
- | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
- | otherwise
- = return $ Just $ ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = True
- , resGet = Just $ handleGet env (toPageName path)
- , resHead = Nothing
- , resPost = Nothing
- , resPut = Just $ handlePut env (toPageName path)
- , resDelete = Just $ handleDelete env (toPageName path)
- }
- where
- toPageName :: [String] -> PageName
- toPageName = decodePageName . dropExtension . joinWith "/"
-
-
-handlePut :: Environment -> PageName -> Resource ()
-handlePut = fail "FIXME: not implemented"
-
-
-handleDelete :: Environment -> PageName -> Resource ()
-handleDelete = fail "FIXME: not implemented"
-module Rakka.Resource.Page.Get
- ( handleGet
+module Rakka.Resource.Render
+ ( fallbackRender
)
where
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
-import Data.Encoding
-import Data.Encoding.UTF8
+import Data.Char
import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Utils
import Network.URI
import Rakka.Environment
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
+import Rakka.Wiki.Engine
+import System.FilePath
import System.Time
+import Text.XML.HXT.Arrow.Namespace
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
+fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
+fallbackRender env path
+ | null path = return Nothing
+ | null $ head path = return Nothing
+ | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
+ | otherwise
+ = return $ Just $ ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Just $ handleGet env (toPageName path)
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+ where
+ toPageName :: [String] -> PageName
+ toPageName = decodePageName . dropExtension . joinWith "/"
+
+
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
= runIdempotentA $ proc ()
{-
HTTP/1.1 302 Found
- Location: http://example.org/Destination?from=Source&revision=112
+ Location: http://example.org/Destination?from=Source
-}
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
<object data="/object/Foo/Bar" /> -- data 屬性に URI
-}
-handleGetEntity :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
+handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
= let sysConf = envSysConf env
in
+= ( case pageIsBinary page of
False -> eelem "content"
- += txt (decodeLazy UTF8 $ pageContent page)
+ += (constA page >>> formatPage)
True -> eelem "object"
+= sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
)
) -<< ()
)
+= ( eelem "div"
+= sattr "class" "body"
- += ( getXPathTreesInDoc "/page/content"
- `guards`
- getXPathTreesInDoc "/page/content/text()" -- FIXME
- )
+ += getXPathTreesInDoc "/page/content/*"
+= ( getXPathTreesInDoc "/page/object"
`guards`
eelem "object"
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
)
-> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
>>> arr read) -< tree
- isTheme <- (maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText)
- >>> defaultTo "no"
+ isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
- >>> defaultTo "no"
+ isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
- >>> defaultTo "no"
+ isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
- >>> defaultTo "no"
+ isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
( yesOrNo
, parseYesOrNo
, maybeA
- , defaultTo
, deleteIfEmpty
, formatW3CDateTime
)
(x:_) -> returnA -< Just x
-defaultTo :: ArrowChoice a => b -> a (Maybe b) b
-defaultTo def
- = proc m -> case m of
- Nothing -> returnA -< def
- Just x -> returnA -< x
-
-
deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
deleteIfEmpty
= proc str -> do case str of
--- /dev/null
+module Rakka.Wiki
+ ( WikiPage
+ , WikiElement(..)
+ , BlockElement(..)
+ , InlineElement(..)
+ )
+ where
+
+type WikiPage = [WikiElement]
+
+
+data WikiElement
+ = Block !BlockElement
+ | Inline !InlineElement
+ deriving (Eq, Show)
+
+
+data BlockElement
+ = Header {
+ hdLevel :: !Int
+ , hdText :: !String
+ }
+ | EmptyLine
+ deriving (Eq, Show)
+
+
+data InlineElement
+ = Text !String
+ deriving (Eq, Show)
--- /dev/null
+module Rakka.Wiki.Engine
+ ( formatPage
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowTree
+import Data.Encoding
+import Data.Encoding.UTF8
+import Network.HTTP.Lucu
+import Rakka.Page
+import Rakka.Wiki.Parser
+import Rakka.Wiki.Formatter
+import Text.ParserCombinators.Parsec
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+
+
+formatPage :: (ArrowXml a, ArrowChoice a) =>
+ a Page XmlTree
+formatPage
+ = proc page
+ -> do tree <- case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> formatWikiPage -< page
+ attachXHtmlNs -< tree
+
+
+formatWikiPage :: (ArrowXml a, ArrowChoice a) =>
+ a Page XmlTree
+formatWikiPage
+ = proc page
+ -> do let source = decodeLazy UTF8 (pageContent page)
+ case parse wikiPage "" source of
+ Left err -> formatParseError -< err
+ Right elems -> formatWikiElements -< elems
+
+
+formatParseError :: ArrowXml a => a ParseError XmlTree
+formatParseError
+ = proc err -> (eelem "pre" += txt (show err)) -<< ()
+
+
+attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
+attachXHtmlNs = processBottomUp (changeQName attach')
+ where
+ attach' :: QName -> QName
+ attach' qn = qn {
+ namePrefix = "xhtml"
+ , namespaceUri = "http://www.w3.org/1999/xhtml"
+ }
--- /dev/null
+module Rakka.Wiki.Formatter
+ ( formatWikiElements
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Data.List
+import Rakka.Wiki
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+
+
+-- 複數の Inline を一つに纏める
+packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]]
+packParagraph elems = map pack grp
+ where
+ grp :: [[WikiElement]]
+ grp = groupBy criteria elems
+
+ criteria :: WikiElement -> WikiElement -> Bool
+ criteria (Inline _) (Inline _) = True
+ criteria _ _ = False
+
+ pack :: [WikiElement] -> Either BlockElement [InlineElement]
+ pack (Block b : []) = Left b
+ pack xs = Right [ case x of
+ Inline i -> i | x <- xs ]
+
+
+formatWikiElements :: (ArrowXml a, ArrowChoice a) => a [WikiElement] XmlTree
+formatWikiElements
+ = proc elems
+ -> do chunk <- arrL id -< packParagraph elems
+ case chunk of
+ Left x -> formatBlock -< x
+ Right xs -> formatParagraph -< xs
+
+
+formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
+formatBlock
+ = proc b
+ -> do case b of
+ Header level text
+ -> formatHeader -< (level, text)
+ EmptyLine
+ -> none -< ()
+
+
+formatHeader :: ArrowXml a => a (Int, String) XmlTree
+formatHeader
+ = proc (level, text)
+ -> selem ("h" ++ show level) [txt text] -<< ()
+
+
+formatParagraph :: (ArrowXml a, ArrowChoice a) => a [InlineElement] XmlTree
+formatParagraph
+ = proc xs
+ -> do elem <- arrL id -< xs
+ tree <- ( eelem "p"
+ += formatInline ) -< elem
+ returnA -< tree
+
+
+formatInline :: (ArrowXml a, ArrowChoice a) => a InlineElement XmlTree
+formatInline
+ = proc i
+ -> do case i of
+ Text text
+ -> mkText -< text
--- /dev/null
+module Rakka.Wiki.Parser
+ ( wikiPage
+ )
+ where
+
+import Rakka.Wiki
+import Text.ParserCombinators.Parsec
+
+
+wikiPage :: Parser WikiPage
+wikiPage = do xs <- many wikiElement
+ eof
+ return xs
+
+
+wikiElement :: Parser WikiElement
+wikiElement = ( try (blockElement >>= return . Block)
+ <|>
+ try (inlineElement >>= return . Inline)
+ )
+
+
+blockElement :: Parser BlockElement
+blockElement = ( try header
+ <|>
+ try emptyLine
+ )
+
+
+header :: Parser BlockElement
+header = foldr (<|>) pzero (map (try . header') [1..5])
+ where
+ header' :: Int -> Parser BlockElement
+ header' n = do count n (char '=')
+ notFollowedBy (char '=')
+ ws
+ x <- notFollowedBy (char '=') >> anyChar
+ xs <- manyTill anyChar (try $ ws >> (count n (char '=')))
+ ws
+ eol
+ return (Header n (x:xs))
+
+
+emptyLine :: Parser BlockElement
+emptyLine = newline >> return EmptyLine
+
+
+inlineElement :: Parser InlineElement
+inlineElement = text
+
+
+text :: Parser InlineElement
+text = do xs <- many1 (noneOf symbols)
+ nl <- option "" (count 1 newline)
+ return $ Text (xs ++ nl)
+
+
+symbols :: [Char]
+symbols = "\n"
+
+
+-- white space
+ws :: Parser String
+ws = many (oneOf " \t")
+
+-- end of line
+eol :: Parser ()
+eol = ( (newline >> return ())
+ <|>
+ eof
+ )
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
+ type="text/x-rakka"
+ isBoring="yes">
+ <textData>= Syntax Help =
+
+== Header ==
+
+=== Header 3 ===
+
+==== Header 4 ====
+
+== Verbatim ==
+ This
+ is a
+ verbatim
+ text.
+
+== Horizontal Line ==
+----
+
+== Quotation ==
+<blockquote>
+blah blah blah...
+blah blah blah blah...
+<cite>-- John Doe<cite>
+
+== Listing ==
+* foo
+** bar
+*** baz
+
+# foo
+## bar
+### baz
+
+* foo
+*# bar
+*#* baz
+*# bar
+
+== Definition ==
+; AAA : aaa
+; BBB
+: bbb
+
+== Link ==
+* [[Page]]
+* [[Page|Link to "Page"]]
+* [[Page#Header]]
+* [[#Header]]
+* [[Page#Header|Link to "Page#Header"]]
+* [[#example]]
+* 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>
<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
type="text/x-rakka"
isBoring="yes">
- <textData>This is the main page. Hello, world!</textData>
+ <textData>= Main Page =
+This is the main page. Hello, world!</textData>
</page>
isBoring="yes"
isTheme="yes">
<textData>
+/* global configuration */
* {
padding: 0;
margin: 0;
list-style-type: none;
}
-body {
- background-color: white;
+/* layout */
+
+.center {
+ position: absolute;
+
+ overflow: auto;
+
+ top: 20px;
+ right: 15em;
+ left: 15em;
+ bottom: 20px;
+}
+
+.left {
+ top: 0em;
+ width: 15em;
+ left: 0;
+ bottom: 0;
+}
+
+.right {
+ top: 0em;
+ width: 15em;
+ right: 0;
+ bottom: 0;
+}
+
+.header {
+ position: absolute;
+ height: 20px;
+ left: 15em;
+ right: 15em;
+ top: 0;
+}
+
+.footer {
+ position: absolute;
+ height: 20px;
+ left: 15em;
+ right: 15em;
+ bottom: 0;
+}
+
+.side-bar {
+ position: absolute;
+ overflow: auto;
+}
+
+/* spacing */
+.body {
+ padding: 25px 30px;
+}
+
+.side-bar .content {
+ padding: 20px;
+}
+
+.side-bar li {
+ padding: 3px;
}
.side-bar ul, .side-bar ol {
.side-bar ul + h1 {
margin-top: 1.2em;
}
+
+/* color and text */
+body {
+ background-color: #white;
+ color: black;
+}
+
+.header, .footer, .side-bar {
+ background-color: #eeeeee;
+}
+
+.side-bar h1 {
+ font-size: 120%;
+ font-weight: bold;
+}
+
+.side-bar a {
+ color: #4e8eff;
+}
+
+.side-bar a:visited {
+ color: #3f73d0;
+}
+
+.side-bar .date {
+ font-size: 70%;
+ white-space: nowrap;
+}
+
+.side-bar .trackbacks p {
+ font-size: 90%;
+}
+
+.side-bar .outline li {
+ list-style-type: circle;
+ margin-left: 1em;
+
+ padding: 0;
+ background-color: black;
+}
+.side-bar .outline li li {
+ list-style-type: disc;
+}
+.side-bar .outline li li li {
+ list-style-type: square;
+}
</textData>
</page>
projects / Rakka.git / commitdiff