import Rakka.Resource.Index
import Rakka.Resource.Object
import Rakka.Resource.Render
+import Rakka.Storage
import Subversion
import System.Console.GetOpt
import System.Directory
| OptGroupName String
| OptLogLevel Priority
| OptDisableStderrLog
+ | OptRebuildIndex
| OptHelp
deriving (Eq, Show)
(NoArg OptDisableStderrLog)
("Disable logging to stderr.")
+ , Option [] ["rebuild-index"]
+ (NoArg OptRebuildIndex)
+ ("Rebuild the index database.")
+
, Option ['h'] ["help"]
(NoArg OptHelp)
"Print this message."
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]
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
run: build
$(EXECUTABLE)
+rebuild-index: build
+ $(EXECUTABLE) --rebuild-index
+
.setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
BUILD_TEST_SUITE=yes ./Setup configure
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
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
mkInterpTable = listToTable $
foldl (++) [] [ Base.interpreters
, Image.interpreters
+ , PageList.interpreters
, Trackback.interpreters
, Outline.interpreters
]
, putPageA
, searchPages
+
+ , rebuildIndex
)
where
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
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 モードで開く。成功したらそのまま返し、失敗したら
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
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 ()
data IndexReq
- = SyncIndex
+ = RebuildIndex
+ | SyncIndex
| SearchIndex !Condition !(TMVar [(PageName, RevNum)])
module Rakka.Wiki
( WikiPage
+
+ , Element(..)
+ , Attribute
+
, BlockElement(..)
, InlineElement(..)
- , ListElement(..)
+ , Definition(..)
+
, ListType(..)
, ListItem
- , Definition(..)
-
, CommandType(..)
- , Attribute
, BlockCommand(..)
, InlineCommand(..)
)
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)
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
deriving (Eq, Show)
-type Attribute = (String, String)
-
-
data BlockCommand
= BlockCommand {
bCmdName :: !String
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" _
wikifyParseError :: ParseError -> WikiPage
wikifyParseError err
= [Div [("class", "error")]
- [ Preformatted [Text (show err)] ]]
+ [ Block (Preformatted [Text (show err)]) ]]
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)
HorizontalLine
-> eelem "hr" -< ()
- List list
+ list@(List _ _)
-> formatListElement -< (baseURI, list)
DefinitionList list
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
)
+= ( (arr fst &&& arrL (snd . snd))
>>>
- formatBlock
+ formatElement
)
) -< (baseURI, (attrs, contents))
[ 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
-> 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
divInterp = BlockCommandInterpreter {
bciName = "div"
, bciInterpret
- = \ _ (BlockCommand _ attrs contents) -> return $ Div attrs contents
+ = \ _ (BlockCommand _ attrs contents)
+ -> return $ Div attrs (map Block contents)
}
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
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
-- <div class="imageFrame ...">
-- <div class="imageData">
--- <p>
--- <a href="...">
--- <img src="..." />
--- </a>
--- </p>
+-- <a href="...">
+-- <img src="..." />
+-- </a>
-- </div>
-- <div class="imageCaption">
-- ...
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 ])
]
)
}
, 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
_ -> 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
, linkFragment = Just text
, linkText = Just text
}
- item = [Right link]
+ item = [Inline link]
in
mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n 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
--- /dev/null
+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 ]
+
+
+-- <div class="recentUpdates">
+-- <ul>
+-- <li>
+-- <a href="...">...</a>
+-- <span class="date">...</span>
+-- <p> <!-- サマリが無ければ存在しない -->
+-- blah blah...
+-- </p>
+-- </li>
+-- ...
+-- </ul>
+-- </div>
+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 -> []
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
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
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.")
+ ])
]
<?xml version="1.0" encoding="UTF-8"?>
<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
type="text/x-rakka"
- isBoring="yes"
- lang="en">
+ isBoring="no"
+ lang="en"><!-- FIXME: isBoring="yes" -->
+
+ <!-- FIXME: delete this -->
+ <summary>The description of syntax of Rakka</summary>
+
<textData><![CDATA[= Syntax Help =
== Heading ==
<?xml version="1.0" encoding="UTF-8"?>
<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
type="text/x-rakka"
- isBoring="yes"
- lang="en">
+ isBoring="no"
+ lang="en"><!-- FIXME: isBoring="yes" -->
<otherLang>
<link lang="ja" page="メインページ" />
</otherLang>
+ <!-- FIXME: delete this -->
+ <summary>The main page to be shown as an index page.</summary>
+
<textData><![CDATA[
= Main Page =
This is the main page.
<textData><![CDATA[
= Control =
-= RSS feeds =
-
= In other languages =
<inOtherLanguages />
= Recent updates =
+<recentUpdates items="20" />
]]></textData>
</page>
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;
}
}
.sideBar li + li {
- margin-top: 0.1em;
+ margin-top: 0.3em;
}
.sideBar * + h1 {
line-height: 1.3;
}
-p {
- margin: 0 0 0.8em 0;
-}
-
h1, h2, h3, h4, h5, h6 {
font-weight: normal;
}
.sideBar .date {
font-size: 70%;
white-space: nowrap;
+ color: #666666;
}
+.sideBar .recentUpdates p,
.sideBar .trackbacks p {
font-size: 90%;
}
}
.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;
, (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<!-- comment -->"
~?=
- (Right [ List (ListElement Bullet [ [Right (Text "a")] ]) ]))
+ (Right [ List Bullet [ [Inline (Text "a")] ] ]))
, (parseWiki "*a<!-- comment -->\n*b"
~?=
- (Right [ List (ListElement Bullet [ [Right (Text "a")]
- , [Right (Text "b")]
- ])
+ (Right [ List Bullet [ [Inline (Text "a")]
+ , [Inline (Text "b")]
+ ]
]))
, (parseWiki "foo:bar"
projects / Rakka.git / commitdiff