From: pho Date: Sat, 17 Nov 2007 08:28:55 +0000 (+0900) Subject: code relocation X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=9681bedbfde02fa1bcda4fbbacba941378c7a57a;p=Rakka.git code relocation darcs-hash:20071117082855-62b54-188ead3a45ed811804115f08ca08ad49a107f812.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index 1551208..a66b4a7 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -88,5 +88,7 @@ Executable RakkaUnitTest ., tests Other-Modules: WikiParserTest + Extensions: + Arrows GHC-Options: -Wall -Werror \ No newline at end of file diff --git a/Rakka/Page.hs b/Rakka/Page.hs index c6469a7..50eb441 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -16,19 +16,33 @@ module Rakka.Page , mkFragmentURI , mkAuxiliaryURI , mkRakkaURI + + , xmlizePage + , parseXmlizedPage ) where +import qualified Codec.Binary.Base64 as B64 import Codec.Binary.UTF8.String +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as L hiding (ByteString) import Data.Char import Data.Map (Map) +import qualified Data.Map as M import Data.Maybe import Data.Time -import Network.HTTP.Lucu +import Network.HTTP.Lucu hiding (redirect) import Network.URI hiding (fragment) +import Rakka.Utils +import Rakka.W3CDateTime import Subversion.Types import System.FilePath.Posix +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlNodeSet +import Text.XML.HXT.DOM.TypeDefs type PageName = String @@ -41,8 +55,8 @@ data Page = Redirection { redirName :: !PageName , redirDest :: !PageName - , redirRevision :: !(Maybe RevNum) - , redirLastMod :: !UTCTime + , redirRevision :: RevNum + , redirLastMod :: UTCTime } | Entity { pageName :: !PageName @@ -54,8 +68,8 @@ data Page , pageIsLocked :: !Bool , pageIsBoring :: !Bool , pageIsBinary :: !Bool - , pageRevision :: !RevNum - , pageLastMod :: !UTCTime + , pageRevision :: RevNum + , pageLastMod :: UTCTime , pageSummary :: !(Maybe String) , pageOtherLang :: !(Map LanguageTag PageName) , pageContent :: !Lazy.ByteString @@ -145,3 +159,155 @@ mkRakkaURI name = URI { , uriQuery = "" , uriFragment = "" } + + +{- + -- デフォルトでない場合のみ存在 + lastModified="2000-01-01T00:00:00"> + + + blah blah... + -- 存在しない場合もある + + -- 存在しない場合もある + + + + + + blah blah... + + + SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS... + + +-} +xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree +xmlizePage + = proc page + -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page + ( eelem "/" + += ( eelem "page" + += sattr "name" (pageName page) + += sattr "type" (show $ pageType page) + += ( case pageLanguage page of + Just x -> sattr "lang" x + Nothing -> none + ) + += ( case pageFileName page of + Just x -> sattr "fileName" x + Nothing -> none + ) + += ( case pageType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + 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 lastMod) + += ( case pageSummary page of + Just s -> eelem "summary" += txt s + Nothing -> none + ) + += ( if M.null (pageOtherLang page) then + none + else + selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" name + | (lang, name) <- M.toList (pageOtherLang page) ] + ) + += ( if pageIsBinary page then + ( eelem "binaryData" + += txt (B64.encode $ L.unpack $ pageContent page) + ) + else + ( eelem "textData" + += txt (decode $ L.unpack $ pageContent page) + ) + ) + )) -<< () + + +parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page +parseXmlizedPage + = proc (name, tree) + -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree + case redirect of + Nothing -> parseEntity -< (name, tree) + Just dest -> returnA -< (Redirection { + redirName = name + , redirDest = dest + , redirRevision = undefined + , redirLastMod = undefined + }) + + +parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page +parseEntity + = proc (name, tree) + -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText + >>> arr read) -< tree + + lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree + fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree + + isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no" + >>> parseYesOrNo) -< tree + isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no" + >>> parseYesOrNo) -< tree + isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no" + >>> parseYesOrNo) -< tree + isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no" + >>> parseYesOrNo) -< tree + + summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()" + >>> getText + >>> deleteIfEmpty)) -< tree + + otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link" + >>> + (getAttrValue0 "lang" + &&& + getAttrValue0 "page")) -< tree + + textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree + binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree + + let (isBinary, content) + = case (textData, binaryData) of + (Just text, Nothing ) -> (False, L.pack $ encode text ) + (Nothing , Just binary) -> (True , L.pack $ B64.decode binary) + _ -> error "one of textData or binaryData is required" + + returnA -< Entity { + pageName = name + , pageType = mimeType + , pageLanguage = lang + , pageFileName = fileName + , pageIsTheme = isTheme + , pageIsFeed = isFeed + , pageIsLocked = isLocked + , pageIsBoring = isBoring + , pageIsBinary = isBinary + , pageRevision = undefined + , pageLastMod = undefined + , pageSummary = summary + , pageOtherLang = M.fromList otherLang + , pageContent = content + } diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 945bfd3..55037f0 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -45,7 +45,7 @@ getPage = ((liftIO .) .) . getPage' . stoRepository putPage :: MonadIO m => Storage -> Page -> RevNum -> m () -putPage _sto _page _oldRev +putPage sto page oldRev = error "FIXME: not implemented" diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 73f4e33..2cc02c3 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -4,29 +4,20 @@ module Rakka.Storage.DefaultPage ) where -import qualified Codec.Binary.Base64 as B64 -import Codec.Binary.UTF8.String import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList -import qualified Data.ByteString.Lazy as L -import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S -import Data.Time import Data.Time.Clock.POSIX import Paths_Rakka -- Cabal が用意する。 import Rakka.Page -import Rakka.Utils import System.Directory import System.FilePath import System.FilePath.Find hiding (fileName, modificationTime) import System.Posix.Files import Text.XML.HXT.Arrow.ReadDocument -import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.XmlNodeSet -import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords @@ -95,73 +86,17 @@ loadPageFileA >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime) -< fpath - parsePage -< (name, lastMod, tree) - - -parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page -parsePage - = proc (name, lastMod, tree) - -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree - case redirect of - Nothing -> parseEntity -< (name, lastMod, tree) - Just dest -> returnA -< (Redirection { - redirName = name - , redirDest = dest - , redirRevision = Nothing - , redirLastMod = lastMod - }) - - -parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page -parseEntity - = proc (name, lastMod, tree) - -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText - >>> arr read) -< tree - - lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree - fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree - - isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - - summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()" - >>> getText - >>> deleteIfEmpty)) -< tree - - otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link" - >>> - (getAttrValue0 "lang" - &&& - getAttrValue0 "page")) -< tree - - textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree - binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree - - let (isBinary, content) - = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ encode text ) - (Nothing , Just binary) -> (True , L.pack $ B64.decode binary) - _ -> error "one of textData or binaryData is required" - - returnA -< Entity { - pageName = name - , pageType = mimeType - , pageLanguage = lang - , pageFileName = fileName - , pageIsTheme = isTheme - , pageIsFeed = isFeed - , pageIsLocked = isLocked - , pageIsBoring = isBoring - , pageIsBinary = isBinary - , pageRevision = 0 - , pageLastMod = lastMod - , pageSummary = summary - , pageOtherLang = M.fromList otherLang - , pageContent = content - } \ No newline at end of file + page <- parseXmlizedPage -< (name, tree) + + case page of + Redirection _ _ _ _ + -> returnA -< page { + redirRevision = 0 + , redirLastMod = lastMod + } + + Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ + -> returnA -< page { + pageRevision = 0 + , pageLastMod = lastMod + } diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 3b9c6e9..7c4487a 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -7,23 +7,18 @@ module Rakka.Wiki.Engine ) where -import qualified Codec.Binary.Base64 as B64 -import Codec.Binary.UTF8.String import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList -import qualified Data.ByteString.Lazy as L import Data.Map (Map) import qualified Data.Map as M import Data.Maybe -import Data.Time import Network.HTTP.Lucu import Network.URI import Rakka.Page import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils -import Rakka.W3CDateTime import Rakka.Wiki import Rakka.Wiki.Parser import Rakka.Wiki.Formatter @@ -38,89 +33,6 @@ import Text.XML.HXT.DOM.TypeDefs type InterpTable = Map String Interpreter -{- - -- デフォルトでない場合のみ存在 - lastModified="2000-01-01T00:00:00"> - - - blah blah... - -- 存在しない場合もある - - -- 存在しない場合もある - - - - - - blah blah... - - - SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS... - - --} -xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree -xmlizePage - = proc page - -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page - ( eelem "/" - += ( eelem "page" - += sattr "name" (pageName page) - += sattr "type" (show $ pageType page) - += ( case pageLanguage page of - Just x -> sattr "lang" x - Nothing -> none - ) - += ( case pageFileName page of - Just x -> sattr "fileName" x - Nothing -> none - ) - += ( case pageType page of - MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ pageIsTheme page) - 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 lastMod) - += ( case pageSummary page of - Just s -> eelem "summary" += txt s - Nothing -> none - ) - += ( if M.null (pageOtherLang page) then - none - else - selem "otherLang" - [ eelem "link" - += sattr "lang" lang - += sattr "page" name - | (lang, name) <- M.toList (pageOtherLang page) ] - ) - += ( if pageIsBinary page then - ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ pageContent page) - ) - else - ( eelem "textData" - += txt (decode $ L.unpack $ pageContent page) - ) - ) - )) -<< () - - wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage wikifyPage interpTable = proc tree