X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=114e2d09db163e1be1f6effa69c7736fad34107d;hb=9d86882fe1630c844e11cf2cf760110c04ea10d4;hp=2462bab30f14d44004fa4fd61e81972fa385fb96;hpb=701592b0fae35ebc8cb4f855c7701c88fc75566b;p=Rakka.git diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 2462bab..114e2d0 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 @@ -29,13 +28,13 @@ 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 import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as L hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Char import Data.Map (Map) import qualified Data.Map as M @@ -43,6 +42,7 @@ import Data.Maybe import Data.Time import Network.HTTP.Lucu hiding (redirect) import Network.URI hiding (fragment) +import OpenSSL.EVP.Base64 import Rakka.Utils import Rakka.W3CDateTime import Subversion.Types @@ -62,6 +62,7 @@ data Page = Redirection { redirName :: !PageName , redirDest :: !PageName + , redirIsLocked :: !Bool , redirRevision :: RevNum , redirLastMod :: UTCTime , redirUpdateInfo :: Maybe UpdateInfo @@ -70,11 +71,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,80 +94,64 @@ 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) -isSafeChar :: Char -> Bool -isSafeChar c - | c == '/' = True - | isReserved c = False - | c > ' ' && c <= '~' = True - | otherwise = False - - -- 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 mkPageURI baseURI name = baseURI { - uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".html"] + uriPath = uriPath baseURI encodePageName name <.> "html" } mkPageFragmentURI :: URI -> PageName -> String -> URI mkPageFragmentURI baseURI name fragment = baseURI { - uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".html"] + uriPath = uriPath baseURI encodePageName name <.> "html" , uriFragment = ('#' : encodeFragment fragment) } @@ -192,6 +175,13 @@ mkAuxiliaryURI baseURI basePath name } +mkFeedURI :: URI -> PageName -> URI +mkFeedURI baseURI name + = baseURI { + uriPath = uriPath baseURI encodePageName name <.> "rdf" + } + + mkRakkaURI :: PageName -> URI mkRakkaURI name = URI { uriScheme = "rakka:" @@ -206,7 +196,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 +267,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) @@ -300,11 +285,11 @@ xmlizePage ) += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ entityContent page) + += txt (L8.unpack $ encodeBase64LBS $ entityContent page) ) else ( eelem "textData" - += txt (decode $ L.unpack $ entityContent page) + += txt (UTF8.decode $ L.unpack $ entityContent page) ) ) )) -<< () @@ -315,11 +300,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 +319,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 +329,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 +345,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 , L8.pack $ decodeBase64 $ 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 +372,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