X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=e396c1b32915fa29568e84c2b26a1ae0c2c18a35;hb=88747f2;hp=f701d92078e757a0ada421d7d54f33e8d4d2b609;hpb=d128bc12ae9f763c37941122bf2e163517810bba;p=Rakka.git diff --git a/Rakka/Page.hs b/Rakka/Page.hs index f701d92..e396c1b 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -15,42 +15,33 @@ module Rakka.Page , encodePageName , decodePageName - , entityFileName' - , defaultFileName - , mkPageURI , mkPageFragmentURI , mkObjectURI , mkFragmentURI , mkAuxiliaryURI + , mkFeedURI , mkRakkaURI , xmlizePage , parseXmlizedPage ) where - -import qualified Codec.Binary.Base64 as B64 -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 -import Data.Maybe import Data.Time +import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu hiding (redirect) import Network.URI hiding (fragment) +import OpenSSL.EVP.Base64 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 +import Text.XML.HXT.XPath type PageName = String @@ -63,6 +54,7 @@ data Page = Redirection { redirName :: !PageName , redirDest :: !PageName + , redirIsLocked :: !Bool , redirRevision :: RevNum , redirLastMod :: UTCTime , redirUpdateInfo :: Maybe UpdateInfo @@ -71,11 +63,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 @@ -96,13 +86,13 @@ 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 @@ -134,15 +124,6 @@ encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName 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 = UTF8.decodeString . unEscapeString @@ -151,32 +132,17 @@ encodeFragment :: String -> String encodeFragment = escapeURIString isSafeChar . UTF8.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 - - 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) } @@ -200,6 +166,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:" @@ -214,7 +187,6 @@ mkRakkaURI name = URI { a Page XmlTree @@ -276,10 +249,6 @@ xmlizePage 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) @@ -289,10 +258,9 @@ 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) + += sattr "lastModified" (W3C.format lastMod) += ( case entitySummary page of Just s -> eelem "summary" += txt s Nothing -> none @@ -308,7 +276,7 @@ xmlizePage ) += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ entityContent page) + += txt (L8.unpack $ encodeBase64LBS $ entityContent page) ) else ( eelem "textData" @@ -323,11 +291,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 @@ -342,7 +313,6 @@ parseEntity 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 @@ -350,8 +320,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 @@ -368,8 +336,8 @@ parseEntity let (isBinary, content) = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ UTF8.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 @@ -384,11 +352,9 @@ parseEntity entityName = name , entityType = mimeType , entityLanguage = lang - , entityFileName = fileName , entityIsTheme = isTheme , entityIsFeed = isFeed , entityIsLocked = isLocked - , entityIsBoring = isBoring , entityIsBinary = isBinary , entityRevision = undefined , entityLastMod = undefined @@ -397,17 +363,25 @@ 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 } - \ No newline at end of file +