X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FPage.hs;h=50eb441b9c851c25a304256b4c6dff0b5685d87b;hp=c6469a7f10552ca37fa97f5e1f2b338e8c16875d;hb=9681bedbfde02fa1bcda4fbbacba941378c7a57a;hpb=f6b697ef834373aab21e3fab64cd3d9f23ae6ab9 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 + }