Tested-With:
GHC == 6.6.1
Build-Depends:
- Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hslogger,
- hxt, mtl, network, parsec, stm, unix
+ Crypto, FileManip, HUnit, HsHyperEstraier, HsSVN, Lucu, base,
+ encoding, filepath, hslogger, hxt, mtl, network, parsec, stm, unix
Data-Files:
defaultpages/Help/SampleImage/Large
defaultpages/Help/SampleImage/Small
)
where
-import Data.Map (Map)
import qualified Data.Map as M
import Network
import qualified Network.HTTP.Lucu.Config as LC
import Rakka.Storage
import Rakka.SystemConfig
+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 Subversion.Repository
import System.Directory
import System.FilePath
+import System.IO
import System.Log.Logger
+
logger = "Rakka.Environment"
envLocalStateDir :: !FilePath
, envLucuConf :: !LC.Config
, envRepository :: !Repository
- , envStorage :: !Storage
, envSysConf :: !SystemConfig
+ , envStorage :: !Storage
, envInterpTable :: !InterpTable
}
-type InterpTable = Map String Interpreter
-
-
setupEnv :: FilePath -> PortNumber -> IO Environment
setupEnv lsdir portNum
= do let lucuConf = LC.defaultConfig {
LC.cnfServerPort = PortNumber portNum
}
reposPath = lsdir `combine` "repos"
- storage = mkStorage
interpTable = mkInterpTable
reposExist <- doesDirectoryExist reposPath
do noticeM logger ("Creating a subversion repository on " ++ reposPath)
createRepository reposPath [] []
sysConf <- mkSystemConfig lucuConf repos
-
+ storage <- mkStorage lsdir repos (makeDraft interpTable)
return $ Environment {
envLocalStateDir = lsdir
, envLucuConf = lucuConf
, envRepository = repos
- , envStorage = storage
, envSysConf = sysConf
+ , envStorage = storage
, envInterpTable = interpTable
}
, mkPageFragmentURI
, mkObjectURI
, mkAuxiliaryURI
+ , mkRakkaURI
)
where
, pageIsLocked :: !Bool
, pageIsBoring :: !Bool
, pageIsBinary :: !Bool
- , pageRevision :: !(Maybe RevNum)
+ , pageRevision :: !RevNum
, pageLastMod :: !CalendarTime
, pageSummary :: !(Maybe String)
, pageOtherLang :: !(Map LanguageTag PageName)
where
isSafe :: Char -> Bool
isSafe c
+ | c == '/' = True
+ | isReserved c = False
| c >= ' ' && c <= '~' = True
| otherwise = False
= baseURI {
uriPath = foldl combine "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
}
+
+
+mkRakkaURI :: PageName -> URI
+mkRakkaURI name = URI {
+ uriScheme = "rakka:"
+ , uriAuthority = Nothing
+ , uriPath = encodePageName name
+ , uriQuery = ""
+ , uriFragment = ""
+ }
= do let lastMod = toClockTime $ pageLastMod page
case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+ 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) lastMod
setContentType (pageType page)
outputLBS (pageContent page)
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowList
import Data.Char
-import qualified Data.Map as M
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
-import Rakka.Utils
import Rakka.Wiki.Engine
import System.FilePath
import System.Time
isTheme="no" -- text/css の場合のみ存在
isFeed="no" -- text/x-rakka の場合のみ存在
isLocked="no"
+ isBinary="no"
revision="112"> -- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00">
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
= proc page
- -> do SiteName siteName <- getSysConfA sysConf -< ()
- BaseURI baseURI <- getSysConfA sysConf -< ()
- StyleSheet cssName <- getSysConfA sysConf -< ()
-
- Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
- Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
- Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
- tree <- ( eelem "/"
- += ( eelem "page"
- += sattr "site" siteName
- += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
- += sattr "name" (pageName page)
- += sattr "type" (show $ pageType page)
- += ( case pageLanguage page of
- Just x -> sattr "lang" x
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "css" _
- -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "x-rakka" _
- -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
- _ -> none
- )
- += sattr "isLocked" (yesOrNo $ pageIsLocked page)
- += ( case pageRevision page of
- Nothing -> none
- Just rev -> sattr "revision" (show rev)
- )
- += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
-
- += ( case pageSummary page of
- Nothing -> none
- Just s -> eelem "summary" += txt s
- )
-
- += ( if M.null (pageOtherLang page) then
- none
- else
- selem "otherLang"
- [ eelem "link"
- += sattr "lang" lang
- += sattr "page" page
- | (lang, page) <- M.toList (pageOtherLang page) ]
- )
- += ( eelem "pageTitle"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "sideBar"
- += ( eelem "left"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "right"
- += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
- >>>
- formatSubPage env
- )
- )
- )
- += ( eelem "body"
- += (constA page >>> formatPage env)
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
+ -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
returnA -< do let lastMod = toClockTime $ pageLastMod page
-- text/x-rakka の場合は、内容が動的に生成され
MIMEType "text" "x-rakka" _
-> return ()
_ -> case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+ 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) lastMod
outputXmlPage tree entityToXHTML
- where
- sysConf :: SystemConfig
- sysConf = envSysConf env
entityToXHTML :: ArrowXml a => a XmlTree XmlTree
handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
handlePageNotFound env
= proc name
- -> do SiteName siteName <- getSysConfA sysConf -< ()
- BaseURI baseURI <- getSysConfA sysConf -< ()
- StyleSheet cssName <- getSysConfA sysConf -< ()
-
- Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
- Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
- Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
- tree <- ( eelem "/"
- += ( eelem "pageNotFound"
- += sattr "site" siteName
- += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
- += sattr "name" name
-
- += ( eelem "pageTitle"
- += ( (constA name &&& constA Nothing &&& constA pageTitle)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "sideBar"
- += ( eelem "left"
- += ( (constA name &&& constA Nothing &&& constA leftSideBar)
- >>>
- formatSubPage env
- )
- )
- += ( eelem "right"
- += ( (constA name &&& constA Nothing &&& constA rightSideBar)
- >>>
- formatSubPage env
- )
- )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
+ -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
returnA -< do setStatus NotFound
outputXmlPage tree notFoundToXHTML
- where
- sysConf :: SystemConfig
- sysConf = envSysConf env
notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
where
import Control.Arrow.ArrowIO
+import Control.Concurrent.STM
+import Control.Monad
import Control.Monad.Trans
+import Data.Set (Set)
import Rakka.Page
import Rakka.Storage.DefaultPage
import Subversion.Types
-
-
-data Storage = Storage -- FIXME
-
-
-mkStorage :: Storage -- FIXME
-mkStorage = Storage
+import System.Directory
+import System.FilePath
+import System.Log.Logger
+import Subversion.Repository
+import Text.HyperEstraier
+
+-- FIXME
+import Data.Encoding
+import Data.Encoding.UTF8
+import qualified Data.ByteString.Lazy.Char8 as C8
+-- FIXME
+
+logger = "Rakka.Storage"
+
+
+data Storage
+ = Storage {
+ stoIndexRevLocked :: !(TVar Bool)
+ , stoIndexRevFile :: !FilePath
+ , stoIndexDB :: !Database
+ , stoRepository :: !Repository
+ , stoMakeDraft :: !(Page -> IO Document)
+ }
+
+
+mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
+mkStorage lsdir repos mkDraft
+ = do let indexDir = lsdir `combine` "index"
+ revFile = lsdir `combine` "indexRev"
+
+ revLocked <- newTVarIO False
+ indexDB <- openIndex indexDir revFile
+
+ let sto = Storage {
+ stoIndexRevLocked = revLocked
+ , stoIndexRevFile = revFile
+ , stoIndexDB = indexDB
+ , stoRepository = repos
+ , stoMakeDraft = mkDraft
+ }
+
+ syncIndex sto
+ return sto
getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page)
putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) ()
-putPageA = arrIO2 . putPage
\ No newline at end of file
+putPageA = arrIO2 . putPage
+
+
+findAllPages :: Storage -> RevNum -> IO (Set PageName)
+findAllPages sto revNum
+ = findAllDefaultPages -- FIXME
+
+
+-- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
+-- indexDir と revFile を削除してから casket を R/W モードで開く。
+openIndex :: FilePath -> FilePath -> IO Database
+openIndex indexDir revFile
+ = do ret <- openDatabase indexDir (Writer [])
+ case ret of
+ Right db
+ -> do debugM logger ("Opened an H.E. database on " ++ indexDir)
+ return db
+
+ Left err
+ -> do warningM logger ("Failed to open an H.E. database on "
+ ++ indexDir ++ ": " ++ show err)
+
+ indexExists <- doesDirectoryExist indexDir
+ when indexExists
+ $ removeDirectoryRecursive indexDir
+
+ revFileExists <- doesFileExist revFile
+ when revFileExists
+ $ removeFile revFile
+
+ Right db <- openDatabase indexDir (Writer [Create []])
+ noticeM logger ("Created an H.E. database on " ++ indexDir)
+
+ return db
+
+
+syncIndex :: Storage -> IO ()
+syncIndex sto
+ = do Just page <- getPage sto "MainPage"
+ doc <- stoMakeDraft sto page
+ putStrLn "*** dumping draft..."
+ dumpDraft doc >>= C8.putStr . encodeLazy UTF8
+ putStrLn "*** dumped"
\ No newline at end of file
module Rakka.Storage.DefaultPage
- ( loadDefaultPage
+ ( findAllDefaultPages
+ , loadDefaultPage
)
where
import Data.Encoding
import Data.Encoding.UTF8
import qualified Data.Map as M
+import Data.Set (Set)
+import qualified Data.Set as S
import Paths_Rakka -- Cabal が用意する。
import Rakka.Page
import Rakka.Utils
+import System.FilePath
+import System.FilePath.Find
import System.Directory
import System.Time
import Text.XML.HXT.Arrow.ReadDocument
import Text.XML.HXT.DOM.XmlKeywords
+doesLocalDirExist :: IO Bool
+doesLocalDirExist = doesDirectoryExist "defaultPages"
+
+
+findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages
+ -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+ -- defaultPages を探す。
+ = do localDirExists <- doesLocalDirExist
+ if localDirExists then
+ findAllIn "defaultPages"
+ else
+ -- FIXME: この getDataFileName の使ひ方は undocumented
+ findAllIn =<< getDataFileName "defaultPages"
+ where
+ findAllIn :: FilePath -> IO (Set PageName)
+ findAllIn dirPath
+ = find always (fileType ==? RegularFile) dirPath
+ >>=
+ return . S.fromList . map (decodePageName . makeRelative dirPath)
+
+
loadDefaultPage :: PageName -> IO (Maybe Page)
loadDefaultPage pageName
- -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
+ -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
+ -- ば Cabal で defaultPages/Foo を探す。
= do let pagePath = "defaultPages/" ++ encodePageName pageName
- isInDataDir <- doesFileExist pagePath
- if isInDataDir then
- return . Just =<< loadPageFile pageName pagePath
+
+ localDirExists <- doesLocalDirExist
+ if localDirExists then
+ tryLoad pagePath
else
- do fpath <- getDataFileName pagePath
- isInstalled <- doesFileExist fpath
- if isInstalled then
- return . Just =<< loadPageFile pageName fpath
- else
- return Nothing
+ tryLoad =<< getDataFileName pagePath
+ where
+ tryLoad :: FilePath -> IO (Maybe Page)
+ tryLoad fpath
+ = do exists <- doesFileExist fpath
+ if exists then
+ return . Just =<< loadPageFile pageName fpath
+ else
+ return Nothing
loadPageFile :: PageName -> FilePath -> IO Page
, pageIsLocked = isLocked
, pageIsBoring = isBoring
, pageIsBinary = isBinary
- , pageRevision = Nothing
+ , pageRevision = 0
, pageLastMod = lastMod
, pageSummary = summary
, pageOtherLang = M.fromList otherLang
module Rakka.Wiki.Engine
- ( formatPage
- , formatSubPage
+ ( InterpTable
+ , formatEntirePage
+ , formatUnexistentPage
+ , makeDraft
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
import Data.Encoding
import Data.Encoding.UTF8
import Data.Generics
+import Data.Map (Map)
import qualified Data.Map as M
+import Data.Maybe
import Network.HTTP.Lucu
-import Rakka.Environment
+import Network.URI
import Rakka.Page
+import Rakka.Storage
import Rakka.SystemConfig
+import Rakka.Utils
import Rakka.Wiki
import Rakka.Wiki.Parser
import Rakka.Wiki.Formatter
import Rakka.Wiki.Interpreter
+import Text.HyperEstraier hiding (getText)
import Text.ParserCombinators.Parsec
+import Text.XML.HXT.Arrow.Namespace
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
-formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a Page XmlTree
-formatPage env
+type InterpTable = Map String Interpreter
+
+
+formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a Page XmlTree
+formatEntirePage sto sysConf interpTable
+ = proc page
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA sto -< "PageTitle"
+ Just leftSideBar <- getPageA sto -< "SideBar/Left"
+ Just rightSideBar <- getPageA sto -< "SideBar/Right"
+
+ tree <- ( eelem "/"
+ += ( eelem "page"
+ += sattr "site" siteName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+ += sattr "name" (pageName page)
+ += sattr "type" (show $ pageType page)
+ += ( case pageLanguage page of
+ Just x -> sattr "lang" x
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "css" _
+ -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
+ _ -> none
+ )
+ += sattr "isLocked" (yesOrNo $ pageIsLocked page)
+ += sattr "isBoring" (yesOrNo $ pageIsBoring page)
+ += sattr "isBinary" (yesOrNo $ pageIsBinary page)
+ += sattr "revision" (show $ pageRevision page)
+ += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
+
+ += ( case pageSummary page of
+ Nothing -> none
+ Just s -> eelem "summary" += txt s
+ )
+
+ += ( if M.null (pageOtherLang page) then
+ none
+ else
+ selem "otherLang"
+ [ eelem "link"
+ += sattr "lang" lang
+ += sattr "page" page
+ | (lang, page) <- M.toList (pageOtherLang page) ]
+ )
+ += ( eelem "pageTitle"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "right"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ )
+ += ( eelem "body"
+ += (constA page >>> formatMainPage sto sysConf interpTable)
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
+ returnA -< tree
+
+
+formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a PageName XmlTree
+formatUnexistentPage sto sysConf interpTable
+ = proc name
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA sto -< "PageTitle"
+ Just leftSideBar <- getPageA sto -< "SideBar/Left"
+ Just rightSideBar <- getPageA sto -< "SideBar/Right"
+
+ tree <- ( eelem "/"
+ += ( eelem "pageNotFound"
+ += sattr "site" siteName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+ += sattr "name" name
+
+ += ( eelem "pageTitle"
+ += ( (constA name &&& constA Nothing &&& constA pageTitle)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA name &&& constA Nothing &&& constA leftSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "right"
+ += ( (constA name &&& constA Nothing &&& constA rightSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
+ returnA -< tree
+
+
+formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a Page XmlTree
+formatMainPage sto sysConf interpTable
= proc page
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
- wiki <- wikifyPage env -< page
- xs <- interpretCommandsA env -< (pageName page, (Just (page, wiki), wiki))
+ -> do BaseURI baseURI <- getSysConfA sysConf -< ()
+ wiki <- arr2 wikifyPage -< (interpTable, page)
+ xs <- interpretCommandsA sto sysConf interpTable
+ -< (pageName page, Just (page, wiki), wiki)
formatWikiBlocks -< (baseURI, xs)
formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
+ Storage
+ -> SystemConfig
+ -> InterpTable
-> a (PageName, (Maybe Page, Page)) XmlTree
-formatSubPage env
+formatSubPage sto sysConf interpTable
= proc (mainPageName, (mainPage, subPage))
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ -> do BaseURI baseURI <- getSysConfA sysConf -< ()
mainWiki <- case mainPage of
Just page
- -> do wiki <- wikifyPage env -< page
+ -> do wiki <- arr2 wikifyPage -< (interpTable, page)
returnA -< Just (page, wiki)
Nothing
-> returnA -< Nothing
- subWiki <- wikifyPage env -< subPage
- xs <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
+ subWiki <- arr2 wikifyPage -< (interpTable, subPage)
+ xs <- interpretCommandsA sto sysConf interpTable
+ -< (mainPageName, mainWiki, subWiki)
formatWikiBlocks -< (baseURI, xs)
-wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a Page WikiPage
-wikifyPage env
- = proc page
- -> case pageType page of
- MIMEType "text" "x-rakka" _
- -> do let source = decodeLazy UTF8 (pageContent page)
- parser = wikiPage tableToFunc
-
- case parse parser "" source of
- Left err
- -> wikifyParseError -< err
-
- Right xs
- -> returnA -< xs
+wikifyPage :: InterpTable -> Page -> WikiPage
+wikifyPage interpTable page
+ = case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> let source = decodeLazy UTF8 (pageContent page)
+ parser = wikiPage tableToFunc
+ in
+ case parse parser "" source of
+ Left err -> wikifyParseError err
+ Right xs -> xs
where
tableToFunc :: String -> Maybe CommandType
tableToFunc name
- = fmap commandType (M.lookup name (envInterpTable env))
+ = fmap commandType (M.lookup name interpTable)
-interpretCommandsA :: ArrowIO a =>
- Environment
- -> a (PageName, (Maybe (Page, WikiPage), WikiPage)) WikiPage
-interpretCommandsA = arrIO3 . interpretCommands
+interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
+interpretCommandsA sto sysConf interpTable
+ = proc (name, mainPageAndTree, targetTree)
+ -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree)
+ -<< ()
-interpretCommands :: Environment -> PageName -> Maybe (Page, WikiPage) -> WikiPage -> IO WikiPage
-interpretCommands _ _ _ [] = return []
-interpretCommands env name mainPageAndTree targetTree
+interpretCommands :: Storage
+ -> SystemConfig
+ -> InterpTable
+ -> PageName
+ -> Maybe (Page, WikiPage)
+ -> WikiPage
+ -> IO WikiPage
+interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
= everywhereM' (mkM interpBlockCmd) targetTree
>>=
everywhereM' (mkM interpInlineCmd)
, ctxMainPage = fmap fst mainPageAndTree
, ctxMainTree = fmap snd mainPageAndTree
, ctxTargetTree = targetTree
- , ctxStorage = envStorage env
- , ctxSysConf = envSysConf env
+ , ctxStorage = sto
+ , ctxSysConf = sysConf
}
interpBlockCmd :: BlockElement -> IO BlockElement
interpBlockCmd' :: BlockCommand -> IO BlockElement
interpBlockCmd' cmd
- = case M.lookup (bCmdName cmd) (envInterpTable env) of
+ = case M.lookup (bCmdName cmd) interpTable of
Nothing
-> fail ("no such interpreter: " ++ bCmdName cmd)
interpInlineCmd' :: InlineCommand -> IO InlineElement
interpInlineCmd' cmd
- = case M.lookup (iCmdName cmd) (envInterpTable env) of
+ = case M.lookup (iCmdName cmd) interpTable of
Nothing
-> fail ("no such interpreter: " ++ iCmdName cmd)
-> iciInterpret interp ctx cmd
+makeDraft :: InterpTable -> Page -> IO Document
+makeDraft interpTable page
+ = do doc <- newDocument
+
+ setURI doc $ Just $ mkRakkaURI $ pageName page
+ setAttribute doc "@title" $ Just $ pageName page
+ setAttribute doc "@lang" $ pageLanguage page
+ setAttribute doc "@type" $ Just $ show $ pageType page
+ setAttribute doc "@mdate" $ Just $ formatW3CDateTime $ pageLastMod 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
+ setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
+
+ case pageType page of
+ MIMEType "text" "css" _
+ -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
+ MIMEType "text" "x-rakka" _
+ -> setAttribute doc "rakka:isFeed" $ Just $ yesOrNo $ pageIsFeed page
+ _ -> return ()
+
+ case pageSummary page of
+ Nothing -> return ()
+ Just s -> addHiddenText doc s
+
+ -- otherLang はリンク先ページ名を hidden text で入れる。
+ sequence_ [ addHiddenText doc x
+ | (_, x) <- M.toList (pageOtherLang page) ]
+
+ -- wikify して興味のある部分を addText する。
+ let wikiPage = wikifyPage interpTable page
+ everywhereM' (mkM (addBlockText doc)) wikiPage
+ everywhereM' (mkM (addInlineText doc)) wikiPage
+
+ return doc
+ where
+ addBlockText :: Document -> BlockElement -> IO BlockElement
+ addBlockText doc b
+ = do case b of
+ Heading _ text
+ -> addText doc text
+ _ -> return ()
+ return b
+
+ addInlineText :: Document -> InlineElement -> IO InlineElement
+ addInlineText doc i
+ = do case i of
+ Text text
+ -> addText doc text
+ PageLink page fragment Nothing
+ -> addText doc (fromMaybe "" page ++
+ fromMaybe "" fragment)
+ PageLink page fragment (Just text)
+ -> do addHiddenText doc (fromMaybe "" page ++
+ fromMaybe "" fragment)
+ addText doc text
+ ExternalLink uri Nothing
+ -> addText doc (uriToString id uri "")
+ ExternalLink uri (Just text)
+ -> do addHiddenText doc (uriToString id uri "")
+ addText doc text
+ _ -> return ()
+ return i
+
+
-- Perform monadic transformation in top-down order.
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' f x = f x >>= gmapM (everywhereM' f)
-wikifyParseError :: ArrowXml a => a ParseError WikiPage
-wikifyParseError
- = proc err -> returnA -< [Div [("class", "error")]
- [ Preformatted [Text (show err)] ]]
+wikifyParseError :: ParseError -> WikiPage
+wikifyParseError err
+ = [Div [("class", "error")]
+ [ Preformatted [Text (show err)] ]]
projects / Rakka.git / commitdiff