From: pho Date: Sat, 27 Oct 2007 08:31:10 +0000 (+0900) Subject: Wrote many... X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=e43bb104a7313dd696b8bb8aa3bafff94706a187;p=Rakka.git Wrote many... darcs-hash:20071027083110-62b54-57bbaae970cf67bf2a0472882a659673832808cc.gz --- diff --git a/Main.hs b/Main.hs index 5ce9eb1..90a47ef 100644 --- a/Main.hs +++ b/Main.hs @@ -8,6 +8,7 @@ import Rakka.Environment import Rakka.Resource.Index import Rakka.Resource.Object import Rakka.Resource.Render +import Rakka.Storage import Subversion import System.Console.GetOpt import System.Directory @@ -30,6 +31,7 @@ data CmdOpt | OptGroupName String | OptLogLevel Priority | OptDisableStderrLog + | OptRebuildIndex | OptHelp deriving (Eq, Show) @@ -76,6 +78,10 @@ options = [ Option ['p'] ["port"] (NoArg OptDisableStderrLog) ("Disable logging to stderr.") + , Option [] ["rebuild-index"] + (NoArg OptRebuildIndex) + ("Rebuild the index database.") + , Option ['h'] ["help"] (NoArg OptHelp) "Print this message." @@ -118,7 +124,9 @@ main = withSubversion $ setupLogger opts env <- setupEnv lsdir portNum - noticeM logger ("Listening to " ++ show portNum ++ "/tcp...") + rebuildIndexIfRequested env opts + + infoM logger ("Listening to " ++ show portNum ++ "/tcp...") runHttpd (envLucuConf env) (resTree env) [fallbackRender env] @@ -202,3 +210,12 @@ createLocalStateDir :: FilePath -> UserID -> GroupID -> IO () createLocalStateDir path uid gid = do createDirectoryIfMissing True path setOwnerAndGroup path uid gid + + +rebuildIndexIfRequested :: Environment -> [CmdOpt] -> IO () +rebuildIndexIfRequested env opts + = do let rebuild = isJust $ find (\ x -> case x of + OptRebuildIndex -> True + _ -> False) opts + when rebuild + $ rebuildIndex (envStorage env) \ No newline at end of file diff --git a/Makefile b/Makefile index 624dbea..a130eff 100644 --- a/Makefile +++ b/Makefile @@ -8,6 +8,9 @@ build: .setup-config Setup run: build $(EXECUTABLE) +rebuild-index: build + $(EXECUTABLE) --rebuild-index + .setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in BUILD_TEST_SUITE=yes ./Setup configure diff --git a/Rakka.cabal b/Rakka.cabal index 2fe7ff5..d536f4f 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -56,6 +56,7 @@ Other-Modules: Rakka.Wiki.Interpreter Rakka.Wiki.Interpreter.Base Rakka.Wiki.Interpreter.Image + Rakka.Wiki.Interpreter.PageList Rakka.Wiki.Interpreter.Trackback Rakka.Wiki.Interpreter.Outline Rakka.Wiki.Engine diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 1941939..321ba7e 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -14,6 +14,7 @@ import Rakka.Wiki.Engine import Rakka.Wiki.Interpreter import qualified Rakka.Wiki.Interpreter.Base as Base import qualified Rakka.Wiki.Interpreter.Image as Image +import qualified Rakka.Wiki.Interpreter.PageList as PageList import qualified Rakka.Wiki.Interpreter.Trackback as Trackback import qualified Rakka.Wiki.Interpreter.Outline as Outline import Subversion.Repository @@ -68,6 +69,7 @@ mkInterpTable :: InterpTable mkInterpTable = listToTable $ foldl (++) [] [ Base.interpreters , Image.interpreters + , PageList.interpreters , Trackback.interpreters , Outline.interpreters ] diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 56b42da..3a883d3 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -10,6 +10,8 @@ module Rakka.Storage , putPageA , searchPages + + , rebuildIndex ) where @@ -65,6 +67,11 @@ searchPages sto cond atomically $ takeTMVar var +rebuildIndex :: MonadIO m => Storage -> m () +rebuildIndex sto + = liftIO $ atomically $ writeTChan (stoIndexChan sto) RebuildIndex + + syncIndex :: Storage -> IO () syncIndex sto = atomically $ writeTChan (stoIndexChan sto) SyncIndex diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index dd8b7c4..5db3f92 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -66,12 +66,22 @@ startIndexManager lsdir repos mkDraft loop chan index = do req <- atomically $ readTChan chan case req of + RebuildIndex + -> do noticeM logger "Rebuilding the H.E. index..." + closeDatabase index + removeDirectoryRecursive indexDir + index' <- openIndex indexDir revFile + syncIndex' index' revFile repos mkDraft + loop chan index' + SyncIndex - -> syncIndex' index revFile repos mkDraft + -> do syncIndex' index revFile repos mkDraft + loop chan index + SearchIndex cond var -> do result <- searchIndex index cond atomically $ putTMVar var result - loop chan index + loop chan index -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら @@ -85,8 +95,8 @@ openIndex indexDir revFile return index Left err - -> do warningM logger ("Failed to open an H.E. index on " - ++ indexDir ++ ": " ++ show err) + -> do noticeM logger ("Failed to open an H.E. index on " + ++ indexDir ++ ": " ++ show err) indexExists <- doesDirectoryExist indexDir when indexExists @@ -112,7 +122,8 @@ syncIndex' index revFile repos mkDraft newRev <- getCurrentRevNum repos debugM logger ("The repository revision is currently " ++ show newRev) - when (newRev /= oldRev) (syncIndex'' oldRev newRev) + when (oldRev == 0 || newRev /= oldRev) + $ syncIndex'' oldRev newRev return newRev where syncIndex'' :: RevNum -> RevNum -> IO () diff --git a/Rakka/Storage/Types.hs b/Rakka/Storage/Types.hs index 8a19041..06870e6 100644 --- a/Rakka/Storage/Types.hs +++ b/Rakka/Storage/Types.hs @@ -19,5 +19,6 @@ data Storage data IndexReq - = SyncIndex + = RebuildIndex + | SyncIndex | SearchIndex !Condition !(TMVar [(PageName, RevNum)]) diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index 613869b..719ed62 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -1,16 +1,18 @@ module Rakka.Wiki ( WikiPage + + , Element(..) + , Attribute + , BlockElement(..) , InlineElement(..) - , ListElement(..) + , Definition(..) + , ListType(..) , ListItem - , Definition(..) - , CommandType(..) - , Attribute , BlockCommand(..) , InlineCommand(..) ) @@ -24,17 +26,29 @@ import Rakka.Page type WikiPage = [BlockElement] +data Element + = Block !BlockElement + | Inline !InlineElement + deriving (Eq, Show, Typeable, Data) + + +type Attribute = (String, String) + + data BlockElement = Heading { headingLevel :: !Int , headingText :: !String } | HorizontalLine - | List !ListElement + | List { + listType :: !ListType + , listItems :: ![ListItem] + } | DefinitionList ![Definition] | Preformatted ![InlineElement] | Paragraph ![InlineElement] - | Div ![Attribute] ![BlockElement] + | Div ![Attribute] ![Element] | EmptyBlock | BlockCmd !BlockCommand deriving (Eq, Show, Typeable, Data) @@ -69,21 +83,13 @@ data InlineElement deriving (Eq, Show, Typeable, Data) -data ListElement - = ListElement { - listType :: !ListType - , listItems :: ![ListItem] - } - deriving (Eq, Show, Typeable, Data) - - data ListType = Bullet | Numbered deriving (Eq, Show, Typeable, Data) -type ListItem = [Either ListElement InlineElement] +type ListItem = [Element] data Definition @@ -100,9 +106,6 @@ data CommandType deriving (Eq, Show) -type Attribute = (String, String) - - data BlockCommand = BlockCommand { bCmdName :: !String diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index b646a52..afbc610 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -309,6 +309,9 @@ makeDraft interpTable page setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page + setAttribute doc "rakka:summary" $ pageSummary page + + addHiddenText doc (pageName page) case pageType page of MIMEType "text" "css" _ @@ -374,4 +377,4 @@ everywhereM' f x = f x >>= gmapM (everywhereM' f) wikifyParseError :: ParseError -> WikiPage wikifyParseError err = [Div [("class", "error")] - [ Preformatted [Text (show err)] ]] + [ Block (Preformatted [Text (show err)]) ]] diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index cc51fef..3f09606 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -24,6 +24,14 @@ formatWikiBlocks attachXHtmlNs -< tree +formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree +formatElement + = proc (baseURI, elem) + -> case elem of + Block b -> formatBlock -< (baseURI, b) + Inline i -> formatInline -< (baseURI, i) + + formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree formatBlock = proc (baseURI, block) @@ -34,7 +42,7 @@ formatBlock HorizontalLine -> eelem "hr" -< () - List list + list@(List _ _) -> formatListElement -< (baseURI, list) DefinitionList list @@ -54,7 +62,7 @@ formatBlock where formatElem :: (ArrowXml a, ArrowChoice a) => String - -> a (URI, [Attribute], [BlockElement]) XmlTree + -> a (URI, [Attribute], [Element]) XmlTree formatElem name = proc (baseURI, attrs, contents) -> ( eelem name @@ -64,7 +72,7 @@ formatBlock ) += ( (arr fst &&& arrL (snd . snd)) >>> - formatBlock + formatElement ) ) -< (baseURI, (attrs, contents)) @@ -77,7 +85,7 @@ formatHeading [ txt text ] -<< () -formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree +formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree formatListElement = proc (baseURI, list) -> let tag = case listType list of @@ -97,16 +105,9 @@ formatListElement -> eelem "li" += ( (arr fst &&& arrL snd) >>> - formatListItem' + formatElement ) -< (baseURI, item) - formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree - formatListItem' - = proc (baseURI, x) - -> case x of - Left nestedList -> formatListElement -< (baseURI, nestedList) - Right inline -> formatInline -< (baseURI, inline ) - formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree formatDefinitionList diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index d36b80d..80ecefc 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -41,7 +41,8 @@ divInterp :: Interpreter divInterp = BlockCommandInterpreter { bciName = "div" , bciInterpret - = \ _ (BlockCommand _ attrs contents) -> return $ Div attrs contents + = \ _ (BlockCommand _ attrs contents) + -> return $ Div attrs (map Block contents) } @@ -66,7 +67,7 @@ otherLangsInterp Just linkTable -> do Languages langTable <- getSysConf (ctxSysConf ctx) let merged = mergeTables langTable (M.toList linkTable) - return $ List $ mkLangList merged + return $ mkLangList merged } where mergeTables :: Map LanguageTag LanguageName @@ -78,9 +79,9 @@ otherLangsInterp in (langName, pageName) : mergeTables m xs - mkLangList :: [(LanguageName, PageName)] -> ListElement - mkLangList xs = ListElement Bullet (map mkLangLink xs) + mkLangList :: [(LanguageName, PageName)] -> BlockElement + mkLangList xs = List Bullet (map mkLangLink xs) mkLangLink :: (LanguageName, PageName) -> ListItem mkLangLink (langName, pageName) - = [Right (PageLink (Just pageName) Nothing (Just langName))] \ No newline at end of file + = [Inline (PageLink (Just pageName) Nothing (Just langName))] \ No newline at end of file diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index 12ea6d6..5482d8c 100644 --- a/Rakka/Wiki/Interpreter/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -47,11 +47,9 @@ imageInterp --
--
---

--- --- --- ---

+-- +-- +-- --
--
-- ... @@ -76,11 +74,11 @@ imgFrameInterp Just others -> error ("unknown \"float\" attribute: " ++ others) return (Div [classAttr] - [ Div [("class", "imageData")] - [ Paragraph [ Anchor [hrefAttr] - [ Image pageName Nothing ] ] - ] - , Div [("class", "imageCaption")] inside + [ Block (Div [("class", "imageData")] + [ Inline (Anchor [hrefAttr] + [ Image pageName Nothing ]) ]) + , Block (Div [("class", "imageCaption")] + [ Block x | x <- inside ]) ] ) } diff --git a/Rakka/Wiki/Interpreter/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs index 04554a6..eb8c9d4 100644 --- a/Rakka/Wiki/Interpreter/Outline.hs +++ b/Rakka/Wiki/Interpreter/Outline.hs @@ -18,12 +18,12 @@ outlineInterp = BlockCommandInterpreter { , bciInterpret = \ ctx _ -> case ctxMainTree ctx of - Just tree -> return $ Div [("class", "outline")] [List $ mkOutline tree] + Just tree -> return $ Div [("class", "outline")] [Block $ mkOutline tree] Nothing -> return EmptyBlock } -mkOutline :: WikiPage -> ListElement +mkOutline :: WikiPage -> BlockElement mkOutline tree = let headings = listify query tree in @@ -36,11 +36,11 @@ query = mkQ False $ \ x -> case x of _ -> False -emptyOutline :: ListElement -emptyOutline = ListElement Bullet [] +emptyOutline :: BlockElement +emptyOutline = List Bullet [] -mkOutline' :: ListElement -> Int -> [BlockElement] -> (ListElement, [BlockElement]) +mkOutline' :: BlockElement -> Int -> [BlockElement] -> (BlockElement, [BlockElement]) mkOutline' soFar _ [] = (soFar, []) mkOutline' soFar level (x:xs) = case x of @@ -53,7 +53,7 @@ mkOutline' soFar level (x:xs) , linkFragment = Just text , linkText = Just text } - item = [Right link] + item = [Inline link] in mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs @@ -72,8 +72,8 @@ mkOutline' soFar level (x:xs) lastItem' :: ListItem lastItem' = case lastItem of - [] -> [Left nested] - i:[] -> i ++ [Left nested] + [] -> [Block nested] + i:[] -> i ++ [Block nested] soFar' = soFar { listItems = nonLastItems ++ [lastItem'] } in diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs new file mode 100644 index 0000000..2a10372 --- /dev/null +++ b/Rakka/Wiki/Interpreter/PageList.hs @@ -0,0 +1,75 @@ +module Rakka.Wiki.Interpreter.PageList + ( interpreters + ) + where + +import Data.Maybe +import Network.HTTP.Lucu.RFC1123DateTime +import Rakka.Page +import Rakka.Storage +import Rakka.Wiki +import Rakka.Wiki.Interpreter +import Text.HyperEstraier + + +interpreters :: [Interpreter] +interpreters = [ recentUpdatesInterp ] + + +--
+--
    +--
  • +-- ... +-- ... +--

    +-- blah blah... +--

    +--
    • +-- ... +--
+--
+recentUpdatesInterp :: Interpreter +recentUpdatesInterp + = BlockCommandInterpreter { + bciName = "recentUpdates" + , bciInterpret + = \ ctx (BlockCommand _ args _) + -> do let items = fromMaybe 10 $ fmap read $ lookup "items" args + sto = ctxStorage ctx + + cond <- newCondition + setPhrase cond "[UVSET]" + addAttrCond cond "rakka:isBoring STREQ no" + addAttrCond cond "rakka:summary STRNE" -- summary が空でない + setOrder cond "@mdate NUMD" + setMax cond items + + result <- searchPages sto cond + pages <- mapM ( \ (name, rev) + -> getPage sto name (Just rev) >>= return . fromJust + ) result + + return $ mkPageList pages + } + where + mkPageList :: [Page] -> BlockElement + mkPageList pages + = Div [("class", "recentUpdates")] + [ Block (List Bullet (map mkListItem pages)) ] + + mkListItem :: Page -> ListItem + mkListItem page + = [ Inline ( PageLink { + linkPage = Just (pageName page) + , linkFragment = Nothing + , linkText = Nothing + } + ) + , Inline ( Span [("class", "date")] + [Text (formatRFC1123DateTime (pageLastMod page))] + ) + ] + ++ + case pageSummary page of + Just s -> [ Block (Paragraph [Text s]) ] + Nothing -> [] diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index 7e0c1a9..6e4edeb 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -73,16 +73,15 @@ horizontalLine = try ( do count 4 (char '-') listElement :: CommandTypeOf -> Parser BlockElement -listElement cmdTypeOf = listElement' [] >>= return . List +listElement cmdTypeOf = listElement' [] where - listElement' :: [Char] -> Parser ListElement + listElement' :: [Char] -> Parser BlockElement listElement' stack = do t <- oneOf "*#" ws xs <- items (stack ++ [t]) - return (ListElement (toType t) xs) + return (List (toType t) xs) - -- ListItem の終了條件は、 items :: [Char] -> Parser [ListItem] items stack = do xs <- many1 $ inlineElement cmdTypeOf nested <- option Nothing @@ -91,7 +90,7 @@ listElement cmdTypeOf = listElement' [] >>= return . List string stack listElement' stack >>= return . Just rest <- items stack - return $ (map Right xs ++ map Left (catMaybes [nested])) : rest + return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest <|> (try $ do skipMany comment newline @@ -271,9 +270,9 @@ blockCmd cmdTypeOf undefinedCmdErr :: String -> BlockElement undefinedCmdErr name = Div [("class", "error")] - [ Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++ - "Make sure you haven't mistyped.") - ] + [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++ + "Make sure you haven't mistyped.") + ]) ] diff --git a/defaultPages/Help/Syntax b/defaultPages/Help/Syntax index d60a5a5..1634607 100644 --- a/defaultPages/Help/Syntax +++ b/defaultPages/Help/Syntax @@ -1,8 +1,12 @@ + isBoring="no" + lang="en"> + + + The description of syntax of Rakka + + isBoring="no" + lang="en"> + + The main page to be shown as an index page. + = Recent updates = + ]]> diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default index 15d58b2..562e02b 100644 --- a/defaultPages/StyleSheet/Default +++ b/defaultPages/StyleSheet/Default @@ -70,6 +70,14 @@ padding: 25px 30px; } +.body p { + margin: 0 0 0.8em 0; +} + +.sideBar p { + margin: 0.2em 0; +} + .body h1, .body h2, .body h3, .body h4, .body h5, .body h6 { margin: 5px 0px; } @@ -132,7 +140,7 @@ } .sideBar li + li { - margin-top: 0.1em; + margin-top: 0.3em; } .sideBar * + h1 { @@ -153,10 +161,6 @@ body { line-height: 1.3; } -p { - margin: 0 0 0.8em 0; -} - h1, h2, h3, h4, h5, h6 { font-weight: normal; } @@ -228,8 +232,10 @@ a { .sideBar .date { font-size: 70%; white-space: nowrap; + color: #666666; } +.sideBar .recentUpdates p, .sideBar .trackbacks p { font-size: 90%; } @@ -252,10 +258,14 @@ a { } .sideBar li { - padding: 2px 5px; + padding: 3px 5px; background-color: #f5f5f5; } +.sideBar .recentUpdates li, .sideBar .trackbacks li { + background-color: #e0e0e0; +} + /* float **********************************************************************/ h1, h2, h3, h4, h5, h6 { clear: both; diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs index f6f642c..56942c6 100644 --- a/tests/WikiParserTest.hs +++ b/tests/WikiParserTest.hs @@ -206,44 +206,44 @@ testData = [ (parseWiki "" , (parseWiki "* a" ~?= - (Right [ List (ListElement Bullet [[Right (Text "a")]]) ])) + (Right [ List Bullet [[Inline (Text "a")]] ])) , (parseWiki "* a*" ~?= - (Right [ List (ListElement Bullet [[Right (Text "a*")]]) ])) + (Right [ List Bullet [[Inline (Text "a*")]] ])) , (parseWiki "* a\n* b\n" ~?= - (Right [ List (ListElement Bullet [ [Right (Text "a")] - , [Right (Text "b")] - ]) + (Right [ List Bullet [ [Inline (Text "a")] + , [Inline (Text "b")] + ] ])) , (parseWiki "*a\n*#b\n*#c\n" ~?= - (Right [ List (ListElement Bullet [ [ Right (Text "a") - , Left (ListElement Numbered [ [Right (Text "b")] - , [Right (Text "c")] - ]) - ] - ]) + (Right [ List Bullet [ [ Inline (Text "a") + , Block (List Numbered [ [Inline (Text "b")] + , [Inline (Text "c")] + ]) + ] + ] ])) , (parseWiki "*a\n#b" ~?= - (Right [ List (ListElement Bullet [ [Right (Text "a")] ]) - , List (ListElement Numbered [ [Right (Text "b")] ]) + (Right [ List Bullet [ [Inline (Text "a")] ] + , List Numbered [ [Inline (Text "b")] ] ])) , (parseWiki "*a" ~?= - (Right [ List (ListElement Bullet [ [Right (Text "a")] ]) ])) + (Right [ List Bullet [ [Inline (Text "a")] ] ])) , (parseWiki "*a\n*b" ~?= - (Right [ List (ListElement Bullet [ [Right (Text "a")] - , [Right (Text "b")] - ]) + (Right [ List Bullet [ [Inline (Text "a")] + , [Inline (Text "b")] + ] ])) , (parseWiki "foo:bar"