^Setup$
^configure$
^dist(/|$)
+^repos(/|$)
import Rakka.Resource.Index
import Rakka.Resource.Object
import Rakka.Resource.Render
+import Subversion
import System.Console.GetOpt
import System.Directory
import System.Environment
main :: IO ()
-main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs
+main = withSubversion $
+ do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs
when (not $ null errors)
$ do mapM_ putStr errors
-fwarn-unused-imports -fglasgow-exts
Build-Depends:
Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hxt, mtl,
- network, parsec, unix
+ network, parsec, stm, unix
Exposed-Modules:
Rakka.Page
Rakka.Storage
Rakka.Resource.Render
Rakka.Wiki.Interpreter.Base
Rakka.Wiki.Interpreter.Base.Image
+ Rakka.Wiki.Interpreter.Base.Outline
Rakka.Wiki.Engine
Rakka.Wiki.Formatter
Rakka.Wiki.Parser
)
where
+import Control.Concurrent.STM
import Control.Arrow.ArrowIO
-import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Network
import Rakka.SystemConfig
import Rakka.Wiki.Interpreter
import Rakka.Wiki.Interpreter.Base
+import Subversion.Repository
+import System.Directory
+import System.FilePath
data Environment = Environment {
envLocalStateDir :: !FilePath
, envLucuConf :: !LC.Config
+ , envRepository :: !Repository
, envStorage :: !Storage
, envSysConf :: !SystemConfig
- , envInterpTable :: !(IORef InterpTable)
+ , envInterpTable :: !(TVar InterpTable)
}
setupEnv :: FilePath -> PortNumber -> IO Environment
setupEnv lsdir portNum
- = do let lucuConf = LC.defaultConfig {
- LC.cnfServerPort = PortNumber portNum
- }
- storage = mkStorage
- sysConf = mkSystemConfig lucuConf
+ = do let lucuConf = LC.defaultConfig {
+ LC.cnfServerPort = PortNumber portNum
+ }
+ reposPath = lsdir `combine` "repos"
+ storage = mkStorage
+
+ reposExist <- doesDirectoryExist reposPath
+ repos <- if reposExist then
+ openRepository reposPath
+ else
+ createRepository reposPath [] []
+ sysConf <- mkSystemConfig lucuConf repos
interpTable <- mkInterpTable
+
return $ Environment {
envLocalStateDir = lsdir
, envLucuConf = lucuConf
+ , envRepository = repos
, envStorage = storage
, envSysConf = sysConf
, envInterpTable = interpTable
}
-mkInterpTable :: IO (IORef InterpTable)
-mkInterpTable = newIORef (listToTable baseInterpreters)
+mkInterpTable :: IO (TVar InterpTable)
+mkInterpTable = newTVarIO (listToTable baseInterpreters)
where
listToTable :: [Interpreter] -> InterpTable
listToTable xs
getInterpTable :: Environment -> IO InterpTable
-getInterpTable = readIORef . envInterpTable
+getInterpTable = atomically . readTVar . envInterpTable
getInterpTableA :: ArrowIO a => Environment -> a b InterpTable
| (lang, page) <- xs ]
)
+= ( eelem "pageTitle"
- += ( (constA (pageName page) &&& constA pageTitle)
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
>>>
formatSubPage env
)
)
+= ( eelem "sideBar"
+= ( eelem "left"
- += ( (constA (pageName page) &&& constA leftSideBar)
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
>>>
formatSubPage env
)
)
+= ( eelem "right"
- += ( (constA (pageName page) &&& constA rightSideBar)
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
>>>
formatSubPage env
)
+= sattr "name" name
+= ( eelem "pageTitle"
- += ( (constA name &&& constA pageTitle)
+ += ( (constA name &&& constA Nothing &&& constA pageTitle)
>>>
formatSubPage env
)
)
+= ( eelem "sideBar"
+= ( eelem "left"
- += ( (constA name &&& constA leftSideBar)
+ += ( (constA name &&& constA Nothing &&& constA leftSideBar)
>>>
formatSubPage env
)
)
+= ( eelem "right"
- += ( (constA name &&& constA rightSideBar)
+ += ( (constA name &&& constA Nothing &&& constA rightSideBar)
>>>
formatSubPage env
)
where
import Control.Arrow.ArrowIO
+import Control.Concurrent.STM
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
+import Data.Encoding
+import Data.Encoding.UTF8
+import Data.Map (Map)
+import qualified Data.Map as M
import Data.Maybe
+import GHC.Conc (unsafeIOToSTM)
import Network
import qualified Network.HTTP.Lucu.Config as LC
import Network.URI
+import Rakka.Utils
+import Subversion.FileSystem
+import Subversion.FileSystem.Revision
+import Subversion.FileSystem.Root
+import Subversion.Repository
+import System.FilePath.Posix
data SystemConfig = SystemConfig {
- scLucuConf :: !LC.Config
+ scLucuConf :: !LC.Config
+ , scRepository :: !Repository
+ , scCache :: !(TVar (Map FilePath SysConfValue))
}
| BaseURI URI
| DefaultPage String
| StyleSheet String
+ deriving (Eq, Show)
-mkSystemConfig :: LC.Config -> SystemConfig
-mkSystemConfig = SystemConfig
+mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
+mkSystemConfig lc repos
+ = do cache <- newTVarIO M.empty
+ return $ SystemConfig {
+ scLucuConf = lc
+ , scRepository = repos
+ , scCache = cache
+ }
getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
getSysConf sc key
- = liftIO $ sysConfDefault sc key -- FIXME
+ = liftIO $
+ atomically $
+ do let path = sysConfPath key
+
+ cache <- readTVar (scCache sc)
+
+ case M.lookup path cache of
+ Just val -> return val
+ Nothing -> do val <- unsafeIOToSTM (getSysConf' sc key)
+ writeTVar (scCache sc) (M.insert path val cache)
+ return val
+
+
+getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
+getSysConf' sc key
+ = do fs <- getRepositoryFS (scRepository sc)
+ rev <- getYoungestRev fs
+ value <- withRevision fs rev
+ $ do let path = fromConfPath (sysConfPath key)
+ exists <- isFile path
+ case exists of
+ True
+ -> do str <- getFileContentsLBS path
+ return $ Just $ chomp $ decodeLazy UTF8 str
+ False
+ -> return Nothing
+ case value of
+ Just str -> return $ unmarshalSysConf key str
+ Nothing -> sysConfDefault sc key
getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
getSysConfA = (arrIO0 .) . getSysConf
+fromConfPath :: FilePath -> FilePath
+fromConfPath = combine "/config"
+
+
{- paths -}
sysConfPath :: SysConfValue -> FilePath
-sysConfPath (SiteName _) = "/siteName"
-sysConfPath (BaseURI _) = "/baseURI"
-sysConfPath (DefaultPage _) = "/defaultPage"
-sysConfPath (StyleSheet _) = "/styleSheet"
+sysConfPath (SiteName _) = "siteName"
+sysConfPath (BaseURI _) = "baseURI"
+sysConfPath (DefaultPage _) = "defaultPage"
+sysConfPath (StyleSheet _) = "styleSheet"
{- marshalling -}
, maybeA
, deleteIfEmpty
, formatW3CDateTime
+ , chomp
)
where
show2 :: Int -> String
show2 n | n < 10 = '0':(show n)
- | otherwise = show n
\ No newline at end of file
+ | otherwise = show n
+
+
+chomp :: String -> String
+chomp = reverse . snd . break (/= '\n') . reverse
| Preformatted ![InlineElement]
| Paragraph ![InlineElement]
| Div ![Attribute] ![BlockElement]
+ | EmptyBlock
| BlockCmd !BlockCommand
deriving (Eq, Show, Typeable, Data)
| Span ![Attribute] ![InlineElement]
| Image ![Attribute]
| Anchor ![Attribute] ![InlineElement]
+ | EmptyInline
| InlineCmd !InlineCommand
deriving (Eq, Show, Typeable, Data)
import Control.Arrow
import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowTree
import Data.Encoding
import Data.Encoding.UTF8
import Data.Generics
-> a Page XmlTree
formatPage env
= proc page
- -> do tree <- case pageType page of
- MIMEType "text" "x-rakka" _
- -> do let source = decodeLazy UTF8 (pageContent page)
- formatWikiPage env -< (pageName page, source)
- attachXHtmlNs -< tree
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+ interpTable <- getInterpTableA env -< ()
+ wiki <- wikifyPage env -< (interpTable, page)
+ xs <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
+ formatWikiBlocks -< (baseURI, xs)
formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
- -> a (PageName, Page) XmlTree
+ -> a (PageName, (Maybe Page, Page)) XmlTree
formatSubPage env
- = proc (mainPageName, subPage)
- -> do tree <- case pageType subPage of
- MIMEType "text" "x-rakka" _
- -> do let source = decodeLazy UTF8 (pageContent subPage)
- formatWikiPage env -< (mainPageName, source)
- attachXHtmlNs -< tree
-
-
-formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a (PageName, String) XmlTree
-formatWikiPage env
- = proc (name, source)
+ = proc (mainPageName, (mainPage, subPage))
-> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
interpTable <- getInterpTableA env -< ()
-
- let parser = wikiPage (tableToFunc interpTable)
-
- case parse parser "" source of
- Left err
- -> formatParseError -< err
-
- Right blocks
- -> do xs <- interpretCommandsA env -< (interpTable, (name, blocks))
- formatWikiBlocks -< (baseURI, xs)
+ mainWiki <- case mainPage of
+ Just page
+ -> do wiki <- wikifyPage env -< (interpTable, page)
+ returnA -< Just wiki
+ Nothing
+ -> returnA -< Nothing
+ subWiki <- wikifyPage env -< (interpTable, subPage)
+ xs <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
+ formatWikiBlocks -< (baseURI, xs)
+
+
+wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a (InterpTable, Page) WikiPage
+wikifyPage env
+ = proc (interpTable, page)
+ -> case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> do let source = decodeLazy UTF8 (pageContent page)
+ parser = wikiPage (tableToFunc interpTable)
+
+ case parse parser "" source of
+ Left err
+ -> wikifyParseError -< err
+
+ Right xs
+ -> returnA -< xs
where
tableToFunc :: InterpTable -> String -> Maybe CommandType
tableToFunc table name
interpretCommandsA :: ArrowIO a =>
Environment
- -> a (InterpTable, (PageName, WikiPage)) WikiPage
-interpretCommandsA = arrIO3 . interpretCommands
+ -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
+interpretCommandsA = arrIO4 . interpretCommands
-interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage
-interpretCommands _ _ _ [] = return []
-interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks
- >>=
- everywhereM' (mkM interpInlineCmd)
+interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
+interpretCommands _ _ _ _ [] = return []
+interpretCommands env table name mainTree targetTree
+ = everywhereM' (mkM interpBlockCmd) targetTree
+ >>=
+ everywhereM' (mkM interpInlineCmd)
where
ctx :: InterpreterContext
ctx = InterpreterContext {
- ctxPageName = name
- , ctxTree = blocks
- , ctxStorage = envStorage env
- , ctxSysConf = envSysConf env
+ ctxPageName = name
+ , ctxMainTree = mainTree
+ , ctxTargetTree = targetTree
+ , ctxStorage = envStorage env
+ , ctxSysConf = envSysConf env
}
interpBlockCmd :: BlockElement -> IO BlockElement
everywhereM' f x = f x >>= gmapM (everywhereM' f)
-formatParseError :: ArrowXml a => a ParseError XmlTree
-formatParseError
- = proc err -> (eelem "pre" += txt (show err)) -<< ()
-
-
-attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
-attachXHtmlNs = processBottomUp (changeQName attach')
- where
- attach' :: QName -> QName
- attach' qn = qn {
- namePrefix = "xhtml"
- , namespaceUri = "http://www.w3.org/1999/xhtml"
- }
+wikifyParseError :: ArrowXml a => a ParseError WikiPage
+wikifyParseError
+ = proc err -> returnA -< [Preformatted [Text (show err)]]
import Control.Arrow
import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
import Data.Char
import Data.List
import Data.Maybe
formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
formatWikiBlocks
= proc (baseURI, blocks)
- -> do block <- arrL id -< blocks
- formatBlock -< (baseURI, block)
+ -> do block <- arrL id -< blocks
+ tree <- formatBlock -< (baseURI, block)
+ attachXHtmlNs -< tree
formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
Div attrs contents
-> formatElem "div" -< (baseURI, attrs, contents)
+
+ EmptyBlock
+ -> none -< ()
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
Anchor attrs contents
-> formatElem "a" -< (baseURI, attrs, contents)
+
+ EmptyInline
+ -> none -< ()
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
+= attr "href" (arr fst >>> mkText)
+= (arr snd >>> mkText)
) -< (href, label)
+
+
+attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
+attachXHtmlNs = processBottomUp (changeQName attach')
+ where
+ attach' :: QName -> QName
+ attach' qn = qn {
+ namePrefix = "xhtml"
+ , namespaceUri = "http://www.w3.org/1999/xhtml"
+ }
data InterpreterContext
= InterpreterContext {
- ctxPageName :: !PageName
- , ctxTree :: !WikiPage
- , ctxStorage :: !Storage
- , ctxSysConf :: !SystemConfig
+ ctxPageName :: !PageName
+ , ctxMainTree :: !(Maybe WikiPage)
+ , ctxTargetTree :: !WikiPage
+ , ctxStorage :: !Storage
+ , ctxSysConf :: !SystemConfig
}
import Rakka.Wiki
import Rakka.Wiki.Interpreter
import Rakka.Wiki.Interpreter.Base.Image
+import Rakka.Wiki.Interpreter.Base.Outline
baseInterpreters :: [Interpreter]
, imgFrameInterp
, pageNameInterp
+ , outlineInterp
]
iciName = "pageName"
, iciInterpret
= \ ctx _ -> return $ Text (ctxPageName ctx)
- }
\ No newline at end of file
+ }
--- /dev/null
+module Rakka.Wiki.Interpreter.Base.Outline
+ ( outlineInterp
+ )
+ where
+
+import Data.Generics
+import Rakka.Wiki
+import Rakka.Wiki.Interpreter
+
+
+outlineInterp :: Interpreter
+outlineInterp = BlockCommandInterpreter {
+ bciName = "outline"
+ , bciInterpret
+ = \ ctx _ ->
+ case ctxMainTree ctx of
+ Just tree -> return $ Div [("class", "outline")] [List $ mkOutline tree]
+ Nothing -> return EmptyBlock
+ }
+
+
+mkOutline :: WikiPage -> ListElement
+mkOutline tree
+ = let headings = listify query tree
+ in
+ fst (mkOutline' emptyOutline 1 headings)
+
+
+query :: Typeable a => a -> Bool
+query = mkQ False $ \ x -> case x of
+ Heading _ _ -> True
+ _ -> False
+
+
+emptyOutline :: ListElement
+emptyOutline = ListElement Bullet []
+
+
+mkOutline' :: ListElement -> Int -> [BlockElement] -> (ListElement, [BlockElement])
+mkOutline' soFar _ [] = (soFar, [])
+mkOutline' soFar level (x:xs)
+ = case x of
+ Heading n text
+ | n == level
+ -- 同じレベルなので soFar に單獨の ListItem を追加して
+ -- 續行。
+ -> let link = PageLink {
+ linkPage = Nothing
+ , linkFragment = Just text
+ , linkText = Just text
+ }
+ item = [Right link]
+ in
+ mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs
+
+ | n < level
+ -- 低いレベルなのでここで終了。
+ -> (soFar, x:xs)
+
+ | n > level
+ -- 高いレベルなので再帰して ListElement を作り、
+ -- それを soFar の最後の ListItem に追加する。
+ -> let (nested, ys) = mkOutline' emptyOutline (level + 1) (x:xs)
+ itemsSoFar = listItems soFar
+
+ nonLastItems, lastItem :: [ListItem]
+ (nonLastItems, lastItem) = splitAt (length itemsSoFar - 1) itemsSoFar
+
+ lastItem' :: ListItem
+ lastItem' = case lastItem of
+ [] -> [Left nested]
+ i:[] -> i ++ [Left nested]
+
+ soFar' = soFar { listItems = nonLastItems ++ [lastItem'] }
+ in
+ mkOutline' soFar' level ys
isBoring="yes">
<textData><
projects / Rakka.git / commitdiff