= do let lucuConf = LC.defaultConfig {
LC.cnfServerPort = PortNumber portNum
}
- reposPath = lsdir `combine` "repos"
+ reposPath = lsdir </> "repos"
interpTable = mkInterpTable
reposExist <- doesDirectoryExist reposPath
, encodePageName
, decodePageName
+
+ , pageFileName'
+
, mkPageURI
, mkPageFragmentURI
, mkObjectURI
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
pageName :: !PageName
, pageType :: !MIMEType
, pageLanguage :: !(Maybe LanguageTag)
+ , pageFileName :: !(Maybe String)
, pageIsTheme :: !Bool -- text/css 以外では無意味
, pageIsFeed :: !Bool -- text/x-rakka 以外では無意味
, pageIsLocked :: !Bool
-- 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
| 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)
}
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])
}
)
where
+import Data.ByteString.Char8 as C8
+import Data.Maybe
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Rakka.Environment
Just redir@(Redirection _ _ _ _)
-> handleRedirect env redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env entity
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)
Just redir@(Redirection _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
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>
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
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 ()
-> 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
pageName = name
, pageType = mimeType
, pageLanguage = lang
+ , pageFileName = fileName
, pageIsTheme = isTheme
, pageIsFeed = isFeed
, pageIsLocked = isLocked
fromConfPath :: FilePath -> FilePath
-fromConfPath = combine "/config"
+fromConfPath = ("/config" </>)
serializeStringPairs :: [(String, String)] -> String
= Text !String
| Italic ![InlineElement]
| Bold ![InlineElement]
+ | ObjectLink {
+ objLinkPage :: !PageName
+ , objLinkText :: !(Maybe String)
+ }
| PageLink {
linkPage :: !(Maybe PageName)
, linkFragment :: !(Maybe String)
}
| LineBreak ![Attribute]
| Span ![Attribute] ![InlineElement]
- | Image ![Attribute]
+ | Image {
+ imgSource :: !PageName
+ , imgAlt :: !(Maybe String)
+ }
| Anchor ![Attribute] ![InlineElement]
| EmptyInline
| InlineCmd !InlineCommand
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)
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
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
= 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)
Bold contents
-> formatElem "b" -< (baseURI, [], contents)
+ link@(ObjectLink _ _)
+ -> formatObjectLink -< (baseURI, link)
+
link@(PageLink _ _ _)
-> formatPageLink -< (baseURI, link)
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)
-> 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
-> 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
= \ 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])
}
= \ 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")
return (Div [classAttr]
[ Div [("class", "imageData")]
[ Paragraph [ Anchor [hrefAttr]
- [ Image [srcAttr] ] ]
+ [ Image pageName Nothing ] ]
]
, Div [("class", "imageCaption")] inside
]
foldr (<|>) pzero [ cdata
, apostrophes cmdTypeOf
, text
+ , objLink
, pageLink
, extLink
, inlineCmd cmdTypeOf
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
== Subsection ==
+* [[[Help/Syntax]]]
+* [[[Help/Syntax|Object of Help/Syntax]]]
* [[Help/Syntax]]
* [http://cielonegro.org/]
* [http://cielonegro.org/ CieloNegro]
</attribute>
</optional>
+ <optional>
+ <attribute name="filename">
+ <text />
+ </attribute>
+ </optional>
+
<optional>
<!-- text/css でなければ無視される -->
<attribute name="isTheme">
~?=
(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 ]