X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Rakka%2FPage.hs;h=d6a93696725b6e280423564e0d1b59ddfde32b60;hb=736016f6e7b9c4ce5cec6d2fe82f8d2911783f8f;hp=50eb441b9c851c25a304256b4c6dff0b5685d87b;hpb=9681bedbfde02fa1bcda4fbbacba941378c7a57a;p=Rakka.git diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 50eb441..d6a9369 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,13 +1,21 @@ module Rakka.Page ( PageName , Page(..) + , UpdateInfo(..) , LanguageTag , LanguageName + , isRedirect + , isEntity + + , pageName + , pageUpdateInfo + , pageRevision + , encodePageName , decodePageName - , pageFileName' + , entityFileName' , defaultFileName , mkPageURI @@ -23,7 +31,7 @@ module Rakka.Page where import qualified Codec.Binary.Base64 as B64 -import Codec.Binary.UTF8.String +import qualified Codec.Binary.UTF8.String as UTF8 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList @@ -53,33 +61,74 @@ type LanguageName = String -- i.e. "日本語" data Page = Redirection { - redirName :: !PageName - , redirDest :: !PageName - , redirRevision :: RevNum - , redirLastMod :: UTCTime + redirName :: !PageName + , redirDest :: !PageName + , redirRevision :: RevNum + , redirLastMod :: UTCTime + , redirUpdateInfo :: Maybe UpdateInfo } | Entity { - pageName :: !PageName - , pageType :: !MIMEType - , pageLanguage :: !(Maybe LanguageTag) - , pageFileName :: !(Maybe String) - , pageIsTheme :: !Bool -- text/css 以外では無意味 - , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味 - , pageIsLocked :: !Bool - , pageIsBoring :: !Bool - , pageIsBinary :: !Bool - , pageRevision :: RevNum - , pageLastMod :: UTCTime - , pageSummary :: !(Maybe String) - , pageOtherLang :: !(Map LanguageTag PageName) - , pageContent :: !Lazy.ByteString + entityName :: !PageName + , entityType :: !MIMEType + , entityLanguage :: !(Maybe LanguageTag) + , entityFileName :: !(Maybe String) + , entityIsTheme :: !Bool -- text/css 以外では無意味 + , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味 + , entityIsLocked :: !Bool + , entityIsBoring :: !Bool + , entityIsBinary :: !Bool + , entityRevision :: RevNum + , entityLastMod :: UTCTime + , entitySummary :: !(Maybe String) + , entityOtherLang :: !(Map LanguageTag PageName) + , entityContent :: !Lazy.ByteString + , entityUpdateInfo :: Maybe UpdateInfo } deriving (Show, Eq) +data UpdateInfo + = UpdateInfo { + uiOldRevision :: !RevNum + , uiOldName :: !(Maybe PageName) + } + deriving (Show, Eq) + + +isRedirect :: Page -> Bool +isRedirect (Redirection _ _ _ _ _) = True +isRedirect _ = False + + +isEntity :: Page -> Bool +isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True +isEntity _ = False + + +pageName :: Page -> PageName +pageName p + | isRedirect p = redirName p + | isEntity p = entityName p + | otherwise = error "neither redirection nor entity" + + +pageUpdateInfo :: Page -> Maybe UpdateInfo +pageUpdateInfo p + | isRedirect p = redirUpdateInfo p + | isEntity p = entityUpdateInfo p + | otherwise = error "neither redirection nor entity" + + +pageRevision :: Page -> RevNum +pageRevision p + | isRedirect p = redirRevision p + | isEntity p = entityRevision p + | otherwise = error "neither redirection nor entity" + + -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath -encodePageName = escapeURIString isSafeChar . encodeString . fixPageName +encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName where fixPageName :: PageName -> PageName fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) @@ -95,16 +144,16 @@ isSafeChar c -- URI unescape して UTF-8 から decode する。 decodePageName :: FilePath -> PageName -decodePageName = decodeString . unEscapeString +decodePageName = UTF8.decodeString . unEscapeString encodeFragment :: String -> String -encodeFragment = escapeURIString isSafeChar . encodeString +encodeFragment = escapeURIString isSafeChar . UTF8.encodeString -pageFileName' :: Page -> String -pageFileName' page - = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page) +entityFileName' :: Page -> String +entityFileName' page + = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page) defaultFileName :: MIMEType -> PageName -> String @@ -170,7 +219,7 @@ mkRakkaURI name = URI { isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" isBinary="no" - revision="112"> -- デフォルトでない場合のみ存在 + revision="112" lastModified="2000-01-01T00:00:00"> @@ -189,79 +238,108 @@ mkRakkaURI name = URI { 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) + -> if isRedirect page then + xmlizeRedirection -< page + else + xmlizeEntity -< page + where + xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree + xmlizeRedirection + = proc page + -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page + ( eelem "/" + += ( eelem "page" + += sattr "name" (redirName page) + += sattr "redirect" (redirDest page) + += sattr "revision" (show $ redirRevision page) + += sattr "lastModified" (formatW3CDateTime lastMod) + )) -<< () + + xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree + xmlizeEntity + = proc page + -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page + ( eelem "/" + += ( eelem "page" + += sattr "name" (pageName page) + += sattr "type" (show $ entityType page) + += ( case entityLanguage page of + Just x -> sattr "lang" x + Nothing -> none + ) + += ( case entityFileName page of + Just x -> sattr "fileName" x + Nothing -> none + ) + += ( case entityType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ entityIsTheme page) + MIMEType "text" "x-rakka" _ + -> sattr "isFeed" (yesOrNo $ entityIsFeed page) + _ + -> none ) - else - ( eelem "textData" - += txt (decode $ L.unpack $ pageContent page) + += sattr "isLocked" (yesOrNo $ entityIsLocked page) + += sattr "isBoring" (yesOrNo $ entityIsBoring page) + += sattr "isBinary" (yesOrNo $ entityIsBinary page) + += sattr "revision" (show $ entityRevision page) + += sattr "lastModified" (formatW3CDateTime lastMod) + += ( case entitySummary page of + Just s -> eelem "summary" += txt s + Nothing -> none ) - ) - )) -<< () + += ( if M.null (entityOtherLang page) then + none + else + selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" name + | (lang, name) <- M.toList (entityOtherLang page) ] + ) + += ( if entityIsBinary page then + ( eelem "binaryData" + += txt (B64.encode $ L.unpack $ entityContent page) + ) + else + ( eelem "textData" + += txt (UTF8.decode $ L.unpack $ entityContent page) + ) + ) + )) -<< () parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page parseXmlizedPage = proc (name, tree) - -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree + -> do updateInfo <- maybeA parseUpdateInfo -< tree + 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 + redirName = name + , redirDest = dest + , redirRevision = undefined + , redirLastMod = undefined + , redirUpdateInfo = updateInfo }) parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page parseEntity = proc (name, tree) - -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText + -> do updateInfo <- maybeA parseUpdateInfo -< tree + + mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read) -< tree lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree @@ -291,23 +369,38 @@ parseEntity let (isBinary, content) = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ encode text ) + (Just text, Nothing ) -> (False, L.pack $ UTF8.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 + entityName = name + , entityType = mimeType + , entityLanguage = lang + , entityFileName = fileName + , entityIsTheme = isTheme + , entityIsFeed = isFeed + , entityIsLocked = isLocked + , entityIsBoring = isBoring + , entityIsBinary = isBinary + , entityRevision = undefined + , entityLastMod = undefined + , entitySummary = summary + , entityOtherLang = M.fromList otherLang + , entityContent = content + , entityUpdateInfo = updateInfo } + + +parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo +parseUpdateInfo + = proc tree + -> do uInfo <- getXPathTreesInDoc "/*/updateInfo" -< tree + oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo + oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo + returnA -< UpdateInfo { + uiOldRevision = oldRev + , uiOldName = oldName + } + + \ No newline at end of file