]> gitweb @ CieloNegro.org - Rakka.git/commitdiff
Wrote more
authorpho <pho@cielonegro.org>
Fri, 26 Oct 2007 09:53:02 +0000 (18:53 +0900)
committerpho <pho@cielonegro.org>
Fri, 26 Oct 2007 09:53:02 +0000 (18:53 +0900)
darcs-hash:20071026095302-62b54-6a79dbb499f55a6c2d253a446c6fc14afb175966.gz

15 files changed:
Rakka/Environment.hs
Rakka/Page.hs
Rakka/Resource/Object.hs
Rakka/Resource/Render.hs
Rakka/Storage.hs
Rakka/Storage/DefaultPage.hs
Rakka/SystemConfig.hs
Rakka/Wiki.hs
Rakka/Wiki/Engine.hs
Rakka/Wiki/Formatter.hs
Rakka/Wiki/Interpreter/Image.hs
Rakka/Wiki/Parser.hs
defaultPages/MainPage
schemas/rakka-page-1.0.rng
tests/WikiParserTest.hs

index f8d824b9516b2a94108d10351cb5739de7f05f1f..1941939d175e7355d5a0e7bb491719cd28876c7c 100644 (file)
@@ -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
index ff1c0ac8a0140fab0cc77c599b556a3ccc73ef80..1fd54c92f326ad1e84e348b0452c3d0541c780b4 100644 (file)
@@ -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])
       }
 
 
index 1a81e6719dc7d61f7d8e20723b969a3e7ee7b667..b029e5422900b69e1b41d4459016f680a6b0dda2 100644 (file)
@@ -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)
index 3c0bd7a6a1ab4ae1dd4740d08fc672c01c10d34c..a22d7c4acaeaac0f56083ec66b359ea79957907b 100644 (file)
@@ -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">
 
     <summary>
index 023806134a52a2854b5da15263133aea984b950a..83bb07795c2a5230230403d4df910663af51975d 100644 (file)
@@ -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 ()
index b5648cf49b64c6c69b7d8cf2ba8b5b06b8313092..3e4e421b4a65d3a61f8daa8196154635cff58318 100644 (file)
@@ -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
index de33f911119eb07aac46ab6dc04cd52cb163bb0a..09c45166530dfc4b5f53fe700ff6aeec0aa0543f 100644 (file)
@@ -114,7 +114,7 @@ getSysConfA = arrIO0 . getSysConf
 
 
 fromConfPath :: FilePath -> FilePath
-fromConfPath = combine "/config"
+fromConfPath = ("/config" </>)
 
 
 serializeStringPairs :: [(String, String)] -> String
index 0fcf38a6bca33b31550bb2ddbc8d5d49f37a19e7..613869b2a9091b83f1b234aa2c20b85ca08caab3 100644 (file)
@@ -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
index 8d5c8eecc0fa87ffbf53812a8916aece7cb1fa72..bb8dc3be9ca4bbe5bc26c90f6acc6b701c4d0816 100644 (file)
@@ -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)
index b81c510594f75253678f9dfc7995899e627615c5..cc51feff644c86a6f3d714adb1bdb27955b098e7 100644 (file)
@@ -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
index f01c2de4f5fac8f8e7976d3cb8531128e7b58b3c..12ea6d662de735ee33a5b1203599b8dd6feb2c40 100644 (file)
@@ -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
                        ]
index eb236ce1e54e57bab3d8c22cbd4e7433d193dc31..7e0c1a90b8517037a10db00011bf630cb9be5d72 100644 (file)
@@ -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 
index cdfb7d6f720233ffc6552921603115e5402bc242..dde08d73d3cca1d90b81b2a86ee1a11e33571b91 100644 (file)
@@ -23,6 +23,8 @@ Another paragraph...
 
 == Subsection ==
 
+* [[[Help/Syntax]]]
+* [[[Help/Syntax|Object of Help/Syntax]]]
 * [[Help/Syntax]]
 * [http://cielonegro.org/]
 * [http://cielonegro.org/ CieloNegro]
index 3fefe6ca38bff6a5fa7971f4405bf07b4fbae2d1..ecd61b78d4f84bf033601f324082083609279190 100644 (file)
         </attribute>
       </optional>
 
+      <optional>
+        <attribute name="filename">
+          <text />
+        </attribute>
+      </optional>
+
       <optional>
         <!-- text/css でなければ無視される -->
         <attribute name="isTheme">
index 4b47e26c58052d5bcb4b50409c36757658bd7ede..f6f642cd06651049f11bd175f6842e6ced75d370 100644 (file)
@@ -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 ]