From 98e508613bb7a50a1f65998ce87f065df957b736 Mon Sep 17 00:00:00 2001 From: pho Date: Fri, 26 Oct 2007 12:39:20 +0900 Subject: [PATCH] Implemented makeDraft and others darcs-hash:20071026033920-62b54-c6804db478b2d82392fc1ec320dc30e8e78cef10.gz --- Rakka.cabal | 4 +- Rakka/Environment.hs | 14 +- Rakka/Page.hs | 15 +- Rakka/Resource/Object.hs | 4 +- Rakka/Resource/Render.hs | 133 +-------------- Rakka/Storage.hs | 97 ++++++++++- Rakka/Storage/DefaultPage.hs | 56 +++++-- Rakka/Wiki/Engine.hs | 316 +++++++++++++++++++++++++++++------ 8 files changed, 430 insertions(+), 209 deletions(-) diff --git a/Rakka.cabal b/Rakka.cabal index 4fdf509..6ccfb14 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -21,8 +21,8 @@ Category: 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 diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index e52f4ef..f8d824b 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -5,12 +5,12 @@ module Rakka.Environment ) 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 @@ -19,8 +19,10 @@ import qualified Rakka.Wiki.Interpreter.Outline as Outline import Subversion.Repository import System.Directory import System.FilePath +import System.IO import System.Log.Logger + logger = "Rakka.Environment" @@ -28,22 +30,18 @@ data Environment = 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 @@ -54,14 +52,14 @@ setupEnv lsdir portNum 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 } diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 380d4a5..ff1c0ac 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -10,6 +10,7 @@ module Rakka.Page , mkPageFragmentURI , mkObjectURI , mkAuxiliaryURI + , mkRakkaURI ) where @@ -47,7 +48,7 @@ data Page , pageIsLocked :: !Bool , pageIsBoring :: !Bool , pageIsBinary :: !Bool - , pageRevision :: !(Maybe RevNum) + , pageRevision :: !RevNum , pageLastMod :: !CalendarTime , pageSummary :: !(Maybe String) , pageOtherLang :: !(Map LanguageTag PageName) @@ -61,6 +62,8 @@ encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 where isSafe :: Char -> Bool isSafe c + | c == '/' = True + | isReserved c = False | c >= ' ' && c <= '~' = True | otherwise = False @@ -95,3 +98,13 @@ mkAuxiliaryURI baseURI basePath name = baseURI { uriPath = foldl combine "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name]) } + + +mkRakkaURI :: PageName -> URI +mkRakkaURI name = URI { + uriScheme = "rakka:" + , uriAuthority = Nothing + , uriPath = encodePageName name + , uriQuery = "" + , uriFragment = "" + } diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index 6f9bd1a..1a81e67 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -63,8 +63,8 @@ handleGetEntity env page = 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) diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 599086b..3c0bd7a 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -6,18 +6,14 @@ module Rakka.Resource.Render 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 @@ -81,6 +77,7 @@ handleRedirect env isTheme="no" -- text/css の場合のみ存在 isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" + isBinary="no" revision="112"> -- デフォルトでない場合のみ存在 lastModified="2000-01-01T00:00:00"> @@ -113,83 +110,7 @@ handleRedirect env 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 の場合は、内容が動的に生成され @@ -199,13 +120,10 @@ handleGetEntity env 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 @@ -291,50 +209,9 @@ entityToXHTML 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 diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 1abace0..fc5637d 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -12,17 +12,56 @@ module Rakka.Storage 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) @@ -40,4 +79,46 @@ getPageA = arrIO . getPage 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 diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 30b5fcf..b5648cf 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -1,5 +1,6 @@ module Rakka.Storage.DefaultPage - ( loadDefaultPage + ( findAllDefaultPages + , loadDefaultPage ) where @@ -11,9 +12,13 @@ import qualified Data.ByteString.Lazy as L 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 @@ -24,20 +29,47 @@ import Text.XML.HXT.DOM.TypeDefs 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 @@ -120,7 +152,7 @@ parseEntity , pageIsLocked = isLocked , pageIsBoring = isBoring , pageIsBinary = isBinary - , pageRevision = Nothing + , pageRevision = 0 , pageLastMod = lastMod , pageSummary = summary , pageOtherLang = M.fromList otherLang diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index b6969cc..8d5c8ee 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,87 +1,242 @@ 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) @@ -92,8 +247,8 @@ interpretCommands env name mainPageAndTree targetTree , ctxMainPage = fmap fst mainPageAndTree , ctxMainTree = fmap snd mainPageAndTree , ctxTargetTree = targetTree - , ctxStorage = envStorage env - , ctxSysConf = envSysConf env + , ctxStorage = sto + , ctxSysConf = sysConf } interpBlockCmd :: BlockElement -> IO BlockElement @@ -102,7 +257,7 @@ interpretCommands env name mainPageAndTree targetTree 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) @@ -116,7 +271,7 @@ interpretCommands env name mainPageAndTree targetTree 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) @@ -124,12 +279,77 @@ interpretCommands env name mainPageAndTree targetTree -> 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)] ]] -- 2.40.0