From ddf0b4d7ab2f1e141edbc7ef75d39853c0846f8c Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 26 Oct 2007 18:53:02 +0900 Subject: [PATCH] Wrote more darcs-hash:20071026095302-62b54-6a79dbb499f55a6c2d253a446c6fc14afb175966.gz --- Rakka/Environment.hs | 2 +- Rakka/Page.hs | 33 +++++++++++++++++++---- Rakka/Resource/Object.hs | 10 ++++--- Rakka/Resource/Render.hs | 11 ++++---- Rakka/Storage.hs | 7 ++--- Rakka/Storage/DefaultPage.hs | 4 ++- Rakka/SystemConfig.hs | 2 +- Rakka/Wiki.hs | 9 ++++++- Rakka/Wiki/Engine.hs | 22 +++++++++++++++ Rakka/Wiki/Formatter.hs | 48 +++++++++++++++++++++++++-------- Rakka/Wiki/Interpreter/Image.hs | 28 ++++++++----------- Rakka/Wiki/Parser.hs | 12 +++++++++ defaultPages/MainPage | 2 ++ schemas/rakka-page-1.0.rng | 6 +++++ tests/WikiParserTest.hs | 8 ++++++ 15 files changed, 156 insertions(+), 48 deletions(-) diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index f8d824b..1941939 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -41,7 +41,7 @@ setupEnv lsdir portNum = do let lucuConf = LC.defaultConfig { LC.cnfServerPort = PortNumber portNum } - reposPath = lsdir `combine` "repos" + reposPath = lsdir "repos" interpTable = mkInterpTable reposExist <- doesDirectoryExist reposPath diff --git a/Rakka/Page.hs b/Rakka/Page.hs index ff1c0ac..1fd54c9 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -6,6 +6,9 @@ module Rakka.Page , encodePageName , decodePageName + + , pageFileName' + , mkPageURI , mkPageFragmentURI , mkObjectURI @@ -16,13 +19,15 @@ module Rakka.Page import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Char8 as C8 +import Data.Char import Data.Encoding import Data.Encoding.UTF8 import Data.Map (Map) +import Data.Maybe import Network.HTTP.Lucu import Network.URI import Subversion.Types -import System.FilePath +import System.FilePath.Posix import System.Time @@ -43,6 +48,7 @@ data Page pageName :: !PageName , pageType :: !MIMEType , pageLanguage :: !(Maybe LanguageTag) + , pageFileName :: !(Maybe String) , pageIsTheme :: !Bool -- text/css 以外では無意味 , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味 , pageIsLocked :: !Bool @@ -58,7 +64,7 @@ data Page -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath -encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 +encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 . fixPageName where isSafe :: Char -> Bool isSafe c @@ -67,23 +73,40 @@ encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 | c >= ' ' && c <= '~' = True | otherwise = False + fixPageName :: PageName -> PageName + fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) + -- URI unescape して UTF-8 から decode する。 decodePageName :: FilePath -> PageName decodePageName = decode UTF8 . C8.pack . unEscapeString +pageFileName' :: Page -> String +pageFileName' page = fromMaybe (defaultFileName page) (pageFileName page) + + +defaultFileName :: Page -> String +defaultFileName page + = let baseName = takeFileName (pageName page) + in + case pageType page of + MIMEType "text" "x-rakka" _ -> baseName <.> "rakka" + MIMEType "text" "css" _ -> baseName <.> "css" + _ -> baseName + + mkPageURI :: URI -> PageName -> URI mkPageURI baseURI name = baseURI { - uriPath = foldl combine "/" [uriPath baseURI, encodePageName name ++ ".html"] + uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".html"] } mkPageFragmentURI :: URI -> PageName -> String -> URI mkPageFragmentURI baseURI name fragment = baseURI { - uriPath = foldl combine "/" [uriPath baseURI, encodePageName name ++ ".html"] + uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".html"] , uriFragment = ('#':fragment) } @@ -96,7 +119,7 @@ mkObjectURI baseURI name mkAuxiliaryURI :: URI -> [String] -> PageName -> URI mkAuxiliaryURI baseURI basePath name = baseURI { - uriPath = foldl combine "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name]) + uriPath = foldl () "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name]) } diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index 1a81e67..b029e54 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -3,6 +3,8 @@ module Rakka.Resource.Object ) where +import Data.ByteString.Char8 as C8 +import Data.Maybe import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Rakka.Environment @@ -38,7 +40,7 @@ handleGet env name Just redir@(Redirection _ _ _ _) -> handleRedirect env redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity env entity @@ -66,5 +68,7 @@ handleGetEntity env page 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ rev -> foundEntity (strongETag $ show rev) lastMod - setContentType (pageType page) - outputLBS (pageContent page) + setContentType (pageType page) + setHeader (C8.pack "Content-Disposition") + (C8.pack $ "attachment; filename=" ++ quoteStr (pageFileName' page)) + outputLBS (pageContent page) diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 3c0bd7a..a22d7c4 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -54,7 +54,7 @@ handleGet env name Just redir@(Redirection _ _ _ _) -> handleRedirect env -< redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity env -< entity {- @@ -73,12 +73,13 @@ handleRedirect env styleSheet="http://example.org/object/StyleSheet/Default" name="Foo/Bar" type="text/x-rakka" - lang="ja" -- 存在しない場合もある - isTheme="no" -- text/css の場合のみ存在 - isFeed="no" -- text/x-rakka の場合のみ存在 + lang="ja" -- 存在しない場合もある + fileName="bar.rakka" -- 存在しない場合もある + isTheme="no" -- text/css の場合のみ存在 + isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" isBinary="no" - revision="112"> -- デフォルトでない場合のみ存在 + revision="112"> -- デフォルトでない場合のみ存在 lastModified="2000-01-01T00:00:00"> diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 0238061..83bb077 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -46,8 +46,8 @@ data Storage mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage mkStorage lsdir repos mkDraft - = do let indexDir = lsdir `combine` "index" - revFile = lsdir `combine` "indexRev" + = do let indexDir = lsdir "index" + revFile = lsdir "indexRev" revLocked <- newTVarIO False indexDB <- openIndex indexDir revFile @@ -137,11 +137,12 @@ syncIndex sto when (newRev /= oldRev) (syncIndex' oldRev newRev) return oldRev -- FIXME + --return newRev where syncIndex' :: RevNum -> RevNum -> IO () syncIndex' oldRev newRev = do pages <- findChangedPages sto oldRev newRev - print pages + print pages -- FIXME updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO () diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index b5648cf..3e4e421 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -114,7 +114,8 @@ parseEntity -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read) -< tree - lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree + lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree + fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no" >>> parseYesOrNo) -< tree @@ -147,6 +148,7 @@ parseEntity pageName = name , pageType = mimeType , pageLanguage = lang + , pageFileName = fileName , pageIsTheme = isTheme , pageIsFeed = isFeed , pageIsLocked = isLocked diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index de33f91..09c4516 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -114,7 +114,7 @@ getSysConfA = arrIO0 . getSysConf fromConfPath :: FilePath -> FilePath -fromConfPath = combine "/config" +fromConfPath = ("/config" ) serializeStringPairs :: [(String, String)] -> String diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index 0fcf38a..613869b 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -44,6 +44,10 @@ data InlineElement = Text !String | Italic ![InlineElement] | Bold ![InlineElement] + | ObjectLink { + objLinkPage :: !PageName + , objLinkText :: !(Maybe String) + } | PageLink { linkPage :: !(Maybe PageName) , linkFragment :: !(Maybe String) @@ -55,7 +59,10 @@ data InlineElement } | LineBreak ![Attribute] | Span ![Attribute] ![InlineElement] - | Image ![Attribute] + | Image { + imgSource :: !PageName + , imgAlt :: !(Maybe String) + } | Anchor ![Attribute] ![InlineElement] | EmptyInline | InlineCmd !InlineCommand diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 8d5c8ee..bb8dc3b 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -60,6 +60,10 @@ formatEntirePage sto sysConf interpTable Just x -> sattr "lang" x _ -> none ) + += ( case pageFileName page of + Just x -> sattr "fileName" x + _ -> none + ) += ( case pageType page of MIMEType "text" "css" _ -> sattr "isTheme" (yesOrNo $ pageIsTheme page) @@ -212,6 +216,18 @@ wikifyPage interpTable page case parse parser "" source of Left err -> wikifyParseError err Right xs -> xs + + MIMEType "image" _ _ + -> [ Paragraph [ Image (pageName page) Nothing ] ] + + _ -> if pageIsBinary page then + -- object へのリンクのみ + [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ] + else + -- pre + let text = decodeLazy UTF8 (pageContent page) + in + [ Preformatted [ Text text ] ] where tableToFunc :: String -> Maybe CommandType tableToFunc name @@ -288,6 +304,7 @@ makeDraft interpTable page setAttribute doc "@lang" $ pageLanguage page setAttribute doc "@type" $ Just $ show $ pageType page setAttribute doc "@mdate" $ Just $ formatW3CDateTime $ pageLastMod page + setAttribute doc "rakka:fileName" $ pageFileName page setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page @@ -328,6 +345,11 @@ makeDraft interpTable page = do case i of Text text -> addText doc text + ObjectLink page Nothing + -> addText doc page + ObjectLink page (Just text) + -> do addHiddenText doc page + addText doc text PageLink page fragment Nothing -> addText doc (fromMaybe "" page ++ fromMaybe "" fragment) diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index b81c510..cc51fef 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -166,6 +166,9 @@ formatInline Bold contents -> formatElem "b" -< (baseURI, [], contents) + link@(ObjectLink _ _) + -> formatObjectLink -< (baseURI, link) + link@(PageLink _ _ _) -> formatPageLink -< (baseURI, link) @@ -178,8 +181,8 @@ formatInline Span attrs contents -> formatElem "span" -< (baseURI, attrs, contents) - Image attrs - -> formatElem "img" -< (baseURI, attrs, []) + img@(Image _ _) + -> formatImage -< (baseURI, img) Anchor attrs contents -> formatElem "a" -< (baseURI, attrs, contents) @@ -209,22 +212,42 @@ attrFromPair = proc (name, value) -> attr name (txt value) -<< () +formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree +formatObjectLink + = proc (baseURI, ObjectLink page text) + -> let uri = mkObjectURI baseURI page + href = uriToString id uri "" + label = fromMaybe ("{" ++ page ++ "}") text + in + mkAnchor -< (href, label) + + formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree formatPageLink = proc (baseURI, PageLink page fragment text) -> let uri = case (page, fragment) of - (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y - (Just x, Nothing) -> mkPageURI baseURI (fix x) + (Just x, Just y) -> mkPageFragmentURI baseURI x y + (Just x, Nothing) -> mkPageURI baseURI x (Nothing, Just y) -> nullURI { uriFragment = ('#':y) } - fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) href = uriToString id uri "" dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment) label = fromMaybe dLabel text in - ( eelem "a" - += attr "href" (arr fst >>> mkText) - += (arr snd >>> mkText) - ) -< (href, label) + mkAnchor -< (href, label) + + +formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree +formatImage = proc (baseURI, Image name alt) + -> let uri = mkObjectURI baseURI name + href = uriToString id uri "" + in + ( eelem "img" + += sattr "src" href + += ( case alt of + Just x -> sattr "alt" x + Nothing -> none + ) + ) -<< () formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree @@ -233,10 +256,13 @@ formatExternalLink -> let href = uriToString id uri "" label = fromMaybe href text in - ( eelem "a" + mkAnchor -< (href, label) + + +mkAnchor :: (ArrowXml a) => a (String, String) XmlTree +mkAnchor = eelem "a" += attr "href" (arr fst >>> mkText) += (arr snd >>> mkText) - ) -< (href, label) attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index f01c2de..12ea6d6 100644 --- a/Rakka/Wiki/Interpreter/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -29,23 +29,19 @@ imageInterp = \ ctx (InlineCommand _ attrs inside) -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) - let pageName = lookup "src" attrs - when (pageName == Nothing) - $ fail "\"src\" attribute is missing" - - let hrefAttr = ("href", uriToString id (mkPageURI baseURI (fromJust pageName)) "") - srcAttr = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "") - altAttr = do alt <- lookup "alt" attrs - return ("alt", alt) + let pageName = case lookup "src" attrs of + Just x -> x + Nothing -> error "\"src\" attribute is missing" + hrefAttr = ("href", uriToString id (mkPageURI baseURI pageName) "") + alt = lookup "alt" attrs classAttr = case lookup "float" attrs of Nothing -> ("class", "inlineImage") Just "left" -> ("class", "inlineImage leftFloat") Just "right" -> ("class", "inlineImage rightFloat") Just others -> error ("unknown \"float\" attribute: " ++ others) anchorAttrs = [hrefAttr, classAttr] - imgAttrs = catMaybes [Just srcAttr, altAttr] - return (Anchor anchorAttrs [Image imgAttrs]) + return (Anchor anchorAttrs [Image pageName alt]) } @@ -69,12 +65,10 @@ imgFrameInterp = \ ctx (BlockCommand _ attrs inside) -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) - let pageName = lookup "src" attrs - when (pageName == Nothing) - $ fail "\"src\" attribute is missing" - - let hrefAttr = ("href", uriToString id (mkPageURI baseURI (fromJust pageName)) "") - srcAttr = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "") + let pageName = case lookup "src" attrs of + Just x -> x + Nothing -> error "\"src\" attribute is missing" + hrefAttr = ("href", uriToString id (mkPageURI baseURI pageName) "") classAttr = case lookup "float" attrs of Nothing -> ("class", "imageFrame") Just "left" -> ("class", "imageFrame leftFloat") @@ -84,7 +78,7 @@ imgFrameInterp return (Div [classAttr] [ Div [("class", "imageData")] [ Paragraph [ Anchor [hrefAttr] - [ Image [srcAttr] ] ] + [ Image pageName Nothing ] ] ] , Div [("class", "imageCaption")] inside ] diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index eb236ce..7e0c1a9 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -283,6 +283,7 @@ inlineElement cmdTypeOf foldr (<|>) pzero [ cdata , apostrophes cmdTypeOf , text + , objLink , pageLink , extLink , inlineCmd cmdTypeOf @@ -344,6 +345,17 @@ apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos n = count n (char '\'') >> notFollowedBy (char '\'') +objLink :: Parser InlineElement +objLink = do try (string "[[[") + page <- many1 (noneOf "|]") + text <- option Nothing + (char '|' >> many1 (satisfy (/= ']')) >>= return . Just) + string "]]]" + return $ ObjectLink page text + + "object link" + + pageLink :: Parser InlineElement pageLink = do try (string "[[") page <- option Nothing diff --git a/defaultPages/MainPage b/defaultPages/MainPage index cdfb7d6..dde08d7 100644 --- a/defaultPages/MainPage +++ b/defaultPages/MainPage @@ -23,6 +23,8 @@ Another paragraph... == Subsection == +* [[[Help/Syntax]]] +* [[[Help/Syntax|Object of Help/Syntax]]] * [[Help/Syntax]] * [http://cielonegro.org/] * [http://cielonegro.org/ CieloNegro] diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng index 3fefe6c..ecd61b7 100644 --- a/schemas/rakka-page-1.0.rng +++ b/schemas/rakka-page-1.0.rng @@ -24,6 +24,12 @@ + + + + + + diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs index 4b47e26..f6f642c 100644 --- a/tests/WikiParserTest.hs +++ b/tests/WikiParserTest.hs @@ -119,6 +119,14 @@ testData = [ (parseWiki "" ~?= (Right [])) + , (parseWiki "[[[Page]]]" + ~?= + (Right [ Paragraph [ ObjectLink "Page" Nothing ] ])) + + , (parseWiki "[[[Page|foo]]]" + ~?= + (Right [ Paragraph [ ObjectLink "Page" (Just "foo") ] ])) + , (parseWiki "[[Page]]" ~?= (Right [ Paragraph [ PageLink (Just "Page") Nothing Nothing ] -- 2.40.0