From 8a7556db44cd91ac0bb52279472bcc2abaa3f18e Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 11 Oct 2007 08:44:39 +0900 Subject: [PATCH] wrote more code... darcs-hash:20071010234439-62b54-2f45ce63eed3f0e32d7579e3b1008ab6a4693bf5.gz --- Main.hs | 5 +- Rakka.cabal | 6 +- Rakka/Resource/Object.hs | 2 +- Rakka/Resource/Page.hs | 40 -------- Rakka/Resource/{Page/Get.hs => Render.hs} | 46 ++++++--- Rakka/Storage/DefaultPage.hs | 12 +-- Rakka/Utils.hs | 8 -- Rakka/Wiki.hs | 29 ++++++ Rakka/Wiki/Engine.hs | 51 ++++++++++ Rakka/Wiki/Formatter.hs | 70 ++++++++++++++ Rakka/Wiki/Parser.hs | 71 ++++++++++++++ defaultPages/Help/Syntax | 65 +++++++++++++ defaultPages/MainPage | 3 +- defaultPages/StyleSheet/Default | 108 +++++++++++++++++++++- 14 files changed, 442 insertions(+), 74 deletions(-) delete mode 100644 Rakka/Resource/Page.hs rename Rakka/Resource/{Page/Get.hs => Render.hs} (84%) create mode 100644 Rakka/Wiki.hs create mode 100644 Rakka/Wiki/Engine.hs create mode 100644 Rakka/Wiki/Formatter.hs create mode 100644 Rakka/Wiki/Parser.hs create mode 100644 defaultPages/Help/Syntax diff --git a/Main.hs b/Main.hs index df2cccb..1b441ee 100644 --- a/Main.hs +++ b/Main.hs @@ -6,7 +6,7 @@ import Network.HTTP.Lucu 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 @@ -15,6 +15,7 @@ import System.Posix.Files import System.Posix.Types import System.Posix.User + data CmdOpt = OptPortNum PortNumber | OptLSDir FilePath @@ -93,7 +94,7 @@ main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs setUserID uid env <- setupEnv lsdir portNum - runHttpd (envLucuConf env) (resTree env) [fallbackPage env] + runHttpd (envLucuConf env) (resTree env) [fallbackRender env] resTree :: Environment -> ResTree diff --git a/Rakka.cabal b/Rakka.cabal index 07f3e41..31c443a 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -25,15 +25,19 @@ Extensions: 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 diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index af0d9b7..73f299b 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -26,7 +26,7 @@ resObject env } where toPageName :: [String] -> PageName - toPageName = decodePageName . dropExtension . joinWith "/" + toPageName = decodePageName . joinWith "/" handleGet :: Environment -> PageName -> Resource () diff --git a/Rakka/Resource/Page.hs b/Rakka/Resource/Page.hs deleted file mode 100644 index 6d8c7d5..0000000 --- a/Rakka/Resource/Page.hs +++ /dev/null @@ -1,40 +0,0 @@ -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" diff --git a/Rakka/Resource/Page/Get.hs b/Rakka/Resource/Render.hs similarity index 84% rename from Rakka/Resource/Page/Get.hs rename to Rakka/Resource/Render.hs index 30da9b9..668d814 100644 --- a/Rakka/Resource/Page/Get.hs +++ b/Rakka/Resource/Render.hs @@ -1,5 +1,5 @@ -module Rakka.Resource.Page.Get - ( handleGet +module Rakka.Resource.Render + ( fallbackRender ) where @@ -7,9 +7,9 @@ import Control.Arrow 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 @@ -17,12 +17,35 @@ import Rakka.Resource 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 () @@ -39,7 +62,7 @@ handleGet env name {- 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 @@ -80,7 +103,7 @@ handleRedirect env -- 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 @@ -129,11 +152,13 @@ handleGetEntity env += ( 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 ) ) -<< () @@ -188,10 +213,7 @@ entityToXHTML ) += ( eelem "div" += sattr "class" "body" - += ( getXPathTreesInDoc "/page/content" - `guards` - getXPathTreesInDoc "/page/content/text()" -- FIXME - ) + += getXPathTreesInDoc "/page/content/*" += ( getXPathTreesInDoc "/page/object" `guards` eelem "object" @@ -216,4 +238,6 @@ entityToXHTML ) ) ) + >>> + uniqueNamespacesFromDeclAndQNames ) diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 5362cc7..00fdf06 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -81,17 +81,13 @@ parseEntity -> 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()" diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index 92f3b12..e411694 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -2,7 +2,6 @@ module Rakka.Utils ( yesOrNo , parseYesOrNo , maybeA - , defaultTo , deleteIfEmpty , formatW3CDateTime ) @@ -35,13 +34,6 @@ maybeA a = listA a (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 diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs new file mode 100644 index 0000000..f08aa96 --- /dev/null +++ b/Rakka/Wiki.hs @@ -0,0 +1,29 @@ +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) diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs new file mode 100644 index 0000000..56a7adb --- /dev/null +++ b/Rakka/Wiki/Engine.hs @@ -0,0 +1,51 @@ +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" + } diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs new file mode 100644 index 0000000..1054d17 --- /dev/null +++ b/Rakka/Wiki/Formatter.hs @@ -0,0 +1,70 @@ +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 diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs new file mode 100644 index 0000000..b5ec74d --- /dev/null +++ b/Rakka/Wiki/Parser.hs @@ -0,0 +1,71 @@ +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 + ) diff --git a/defaultPages/Help/Syntax b/defaultPages/Help/Syntax new file mode 100644 index 0000000..39c38f4 --- /dev/null +++ b/defaultPages/Help/Syntax @@ -0,0 +1,65 @@ + + + = 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> + + + + diff --git a/defaultPages/MainPage b/defaultPages/MainPage index 3da51be..632b1bd 100644 --- a/defaultPages/MainPage +++ b/defaultPages/MainPage @@ -2,5 +2,6 @@ - This is the main page. Hello, world! + = Main Page = +This is the main page. Hello, world! diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default index b01806f..e7ab1ad 100644 --- a/defaultPages/StyleSheet/Default +++ b/defaultPages/StyleSheet/Default @@ -4,6 +4,7 @@ isBoring="yes" isTheme="yes"> +/* global configuration */ * { padding: 0; margin: 0; @@ -11,8 +12,65 @@ 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 { @@ -26,5 +84,51 @@ body { .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; +} -- 2.40.0