X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=b293b1fb0258445edfec5261687c3996c1893e9a;hb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;hp=50eb441b9c851c25a304256b4c6dff0b5685d87b;hpb=9681bedbfde02fa1bcda4fbbacba941378c7a57a;p=Rakka.git diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 50eb441..b293b1f 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,13 +1,20 @@ module Rakka.Page ( PageName , Page(..) + , UpdateInfo(..) , LanguageTag , LanguageName + , isRedirect + , isEntity + + , pageName + , pageUpdateInfo + , encodePageName , decodePageName - , pageFileName' + , entityFileName' , defaultFileName , mkPageURI @@ -53,30 +60,64 @@ 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 = fail "neither redirection nor entity" + + +pageUpdateInfo :: Page -> Maybe UpdateInfo +pageUpdateInfo p + | isRedirect p = redirUpdateInfo p + | isEntity p = entityUpdateInfo p + | otherwise = fail "neither redirection nor entity" + + -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath encodePageName = escapeURIString isSafeChar . encodeString . fixPageName @@ -102,9 +143,9 @@ encodeFragment :: String -> String encodeFragment = escapeURIString isSafeChar . 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 @@ -193,52 +234,52 @@ mkRakkaURI name = URI { xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree xmlizePage = proc page - -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page + -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page ( eelem "/" += ( eelem "page" += sattr "name" (pageName page) - += sattr "type" (show $ pageType page) - += ( case pageLanguage page of + += sattr "type" (show $ entityType page) + += ( case entityLanguage page of Just x -> sattr "lang" x Nothing -> none ) - += ( case pageFileName page of + += ( case entityFileName page of Just x -> sattr "fileName" x Nothing -> none ) - += ( case pageType page of + += ( case entityType page of MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + -> sattr "isTheme" (yesOrNo $ entityIsTheme page) MIMEType "text" "x-rakka" _ - -> sattr "isFeed" (yesOrNo $ pageIsFeed page) + -> sattr "isFeed" (yesOrNo $ entityIsFeed page) _ -> none ) - += sattr "isLocked" (yesOrNo $ pageIsLocked page) - += sattr "isBoring" (yesOrNo $ pageIsBoring page) - += sattr "isBinary" (yesOrNo $ pageIsBinary page) - += sattr "revision" (show $ pageRevision 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 pageSummary page of + += ( case entitySummary page of Just s -> eelem "summary" += txt s Nothing -> none ) - += ( if M.null (pageOtherLang page) then + += ( if M.null (entityOtherLang page) then none else selem "otherLang" [ eelem "link" += sattr "lang" lang += sattr "page" name - | (lang, name) <- M.toList (pageOtherLang page) ] + | (lang, name) <- M.toList (entityOtherLang page) ] ) - += ( if pageIsBinary page then + += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ pageContent page) + += txt (B64.encode $ L.unpack $ entityContent page) ) else ( eelem "textData" - += txt (decode $ L.unpack $ pageContent page) + += txt (decode $ L.unpack $ entityContent page) ) ) )) -<< () @@ -247,21 +288,25 @@ xmlizePage 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 @@ -296,18 +341,33 @@ parseEntity _ -> 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