X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=ec43df852c2d252ab758bfffe0e0e22ecf981c9d;hb=f57c5c5ae6c95e68b11400718e7ce5de4ea1317a;hp=2462bab30f14d44004fa4fd61e81972fa385fb96;hpb=701592b0fae35ebc8cb4f855c7701c88fc75566b;p=Rakka.git diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 2462bab..ec43df8 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -10,18 +10,17 @@ module Rakka.Page , pageName , pageUpdateInfo + , pageRevision , encodePageName , decodePageName - , entityFileName' - , defaultFileName - , mkPageURI , mkPageFragmentURI , mkObjectURI , mkFragmentURI , mkAuxiliaryURI + , mkFeedURI , mkRakkaURI , xmlizePage @@ -30,7 +29,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 @@ -62,6 +61,7 @@ data Page = Redirection { redirName :: !PageName , redirDest :: !PageName + , redirIsLocked :: !Bool , redirRevision :: RevNum , redirLastMod :: UTCTime , redirUpdateInfo :: Maybe UpdateInfo @@ -70,11 +70,9 @@ data Page 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 @@ -95,32 +93,39 @@ data UpdateInfo isRedirect :: Page -> Bool -isRedirect (Redirection _ _ _ _ _) = True -isRedirect _ = False +isRedirect (Redirection _ _ _ _ _ _) = True +isRedirect _ = False isEntity :: Page -> Bool -isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True -isEntity _ = False +isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True +isEntity _ = False pageName :: Page -> PageName pageName p | isRedirect p = redirName p | isEntity p = entityName p - | otherwise = fail "neither redirection nor entity" + | otherwise = error "neither redirection nor entity" pageUpdateInfo :: Page -> Maybe UpdateInfo pageUpdateInfo p | isRedirect p = redirUpdateInfo p | isEntity p = entityUpdateInfo p - | otherwise = fail "neither redirection nor entity" + | 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) @@ -136,26 +141,11 @@ isSafeChar c -- URI unescape して UTF-8 から decode する。 decodePageName :: FilePath -> PageName -decodePageName = decodeString . unEscapeString +decodePageName = UTF8.decodeString . unEscapeString encodeFragment :: String -> String -encodeFragment = escapeURIString isSafeChar . encodeString - - -entityFileName' :: Page -> String -entityFileName' page - = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page) - - -defaultFileName :: MIMEType -> PageName -> String -defaultFileName pType pName - = let baseName = takeFileName pName - in - case pType of - MIMEType "text" "x-rakka" _ -> baseName <.> "rakka" - MIMEType "text" "css" _ -> baseName <.> "css" - _ -> baseName +encodeFragment = escapeURIString isSafeChar . UTF8.encodeString mkPageURI :: URI -> PageName -> URI @@ -192,6 +182,13 @@ mkAuxiliaryURI baseURI basePath name } +mkFeedURI :: URI -> PageName -> URI +mkFeedURI baseURI name + = baseURI { + uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".rdf"] + } + + mkRakkaURI :: PageName -> URI mkRakkaURI name = URI { uriScheme = "rakka:" @@ -206,7 +203,6 @@ mkRakkaURI name = URI { 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) @@ -281,7 +274,6 @@ xmlizePage -> none ) += sattr "isLocked" (yesOrNo $ entityIsLocked page) - += sattr "isBoring" (yesOrNo $ entityIsBoring page) += sattr "isBinary" (yesOrNo $ entityIsBinary page) += sattr "revision" (show $ entityRevision page) += sattr "lastModified" (formatW3CDateTime lastMod) @@ -304,7 +296,7 @@ xmlizePage ) else ( eelem "textData" - += txt (decode $ L.unpack $ entityContent page) + += txt (UTF8.decode $ L.unpack $ entityContent page) ) ) )) -<< () @@ -315,11 +307,14 @@ parseXmlizedPage = proc (name, tree) -> do updateInfo <- maybeA parseUpdateInfo -< tree redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree + isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no" + >>> parseYesOrNo) -< tree case redirect of Nothing -> parseEntity -< (name, tree) Just dest -> returnA -< (Redirection { redirName = name , redirDest = dest + , redirIsLocked = isLocked , redirRevision = undefined , redirLastMod = undefined , redirUpdateInfo = updateInfo @@ -331,11 +326,9 @@ parseEntity = proc (name, tree) -> do updateInfo <- maybeA parseUpdateInfo -< tree - mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText - >>> arr read) -< tree + mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< 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 @@ -343,8 +336,6 @@ parseEntity >>> 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 @@ -361,19 +352,25 @@ parseEntity let (isBinary, content) = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ encode text ) - (Nothing , Just binary) -> (True , L.pack $ B64.decode binary) + (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text ) + (Nothing , Just binary) -> (True , L.pack $ fromJust $ B64.decode $ dropWhitespace binary) _ -> error "one of textData or binaryData is required" + mimeType + = if isBinary then + if null mimeTypeStr then + guessMIMEType content + else + read mimeTypeStr + else + read mimeTypeStr returnA -< Entity { entityName = name , entityType = mimeType , entityLanguage = lang - , entityFileName = fileName , entityIsTheme = isTheme , entityIsFeed = isFeed , entityIsLocked = isLocked - , entityIsBoring = isBoring , entityIsBinary = isBinary , entityRevision = undefined , entityLastMod = undefined @@ -382,14 +379,22 @@ parseEntity , entityContent = content , entityUpdateInfo = updateInfo } + where + dropWhitespace :: String -> String + dropWhitespace [] = [] + dropWhitespace (x:xs) + | x == ' ' || x == '\t' || x == '\n' + = dropWhitespace xs + | otherwise + = x : dropWhitespace xs parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo parseUpdateInfo = proc tree - -> do uInfo <- getXPathTreesInDoc "/*/updateInfo" -< tree + -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo - oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo + oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo returnA -< UpdateInfo { uiOldRevision = oldRev , uiOldName = oldName