X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FPage.hs;h=b4c88fcc5f2fef07de28d67825e62b68f6c03112;hp=c1d72119e348c1f7ca02dadd980cd1e440912f1c;hb=HEAD;hpb=5311fe068286b30d52063ef97cc00f09f65a47f1 diff --git a/Rakka/Page.hs b/Rakka/Page.hs index c1d7211..b4c88fc 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + Arrows + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Page ( PageName , Page(..) @@ -20,46 +25,53 @@ module Rakka.Page , mkObjectURI , mkFragmentURI , mkAuxiliaryURI + , mkFeedURI , mkRakkaURI , xmlizePage , parseXmlizedPage ) where - -import qualified Codec.Binary.Base64 as B64 +import Control.Applicative +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Arrow.Unicode import qualified Codec.Binary.UTF8.String as UTF8 -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowList +import qualified Data.ByteString.Char8 as B8 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.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Char import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding 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 Prelude.Unicode 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 - - -type PageName = String - -type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt -type LanguageName = String -- i.e. "日本語" +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.XPath +type PageName = Text +type LanguageTag = CI Text -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt +type LanguageName = Text -- i.e. "日本語" data Page = Redirection { redirName :: !PageName , redirDest :: !PageName + , redirIsLocked :: !Bool , redirRevision :: RevNum , redirLastMod :: UTCTime , redirUpdateInfo :: Maybe UpdateInfo @@ -71,7 +83,6 @@ data Page , entityIsTheme :: !Bool -- text/css 以外では無意味 , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味 , entityIsLocked :: !Bool - , entityIsBoring :: !Bool , entityIsBinary :: !Bool , entityRevision :: RevNum , entityLastMod :: UTCTime @@ -82,7 +93,6 @@ data Page } deriving (Show, Eq) - data UpdateInfo = UpdateInfo { uiOldRevision :: !RevNum @@ -92,13 +102,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 @@ -123,46 +133,37 @@ pageRevision p -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 -encodePageName :: PageName -> FilePath -encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName +encodePageName ∷ PageName → FilePath +encodePageName = escapeURIString isSafeChar ∘ UTF8.encodeString ∘ fixPageName ∘ T.unpack where - fixPageName :: PageName -> PageName - fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) - + fixPageName ∷ String → String + fixPageName = capitalizeHead ∘ map (\c → if c ≡ ' ' then '_' else c) -isSafeChar :: Char -> Bool -isSafeChar c - | c == '/' = True - | isReserved c = False - | c > ' ' && c <= '~' = True - | otherwise = False + capitalizeHead ∷ String → String + capitalizeHead [] = (⊥) + capitalizeHead (x:xs) = toUpper x : xs +-- FIXME: use system-filepath +decodePageName ∷ FilePath → PageName +decodePageName = T.pack ∘ UTF8.decodeString ∘ unEscapeString --- URI unescape して UTF-8 から decode する。 -decodePageName :: FilePath -> PageName -decodePageName = UTF8.decodeString . unEscapeString +encodeFragment ∷ Text → String +encodeFragment = escapeURIString isSafeChar ∘ B8.unpack ∘ encodeUtf8 - -encodeFragment :: String -> String -encodeFragment = escapeURIString isSafeChar . UTF8.encodeString - - -mkPageURI :: URI -> PageName -> URI +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 ∷ URI → PageName → Text → URI mkPageFragmentURI baseURI name fragment = baseURI { - uriPath = foldl () "/" [uriPath baseURI, encodePageName name ++ ".html"] + uriPath = uriPath baseURI encodePageName name <.> "html" , uriFragment = ('#' : encodeFragment fragment) } - -mkFragmentURI :: String -> URI +mkFragmentURI ∷ Text → URI mkFragmentURI fragment = nullURI { uriFragment = ('#' : encodeFragment fragment) @@ -181,6 +182,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:" @@ -238,10 +246,11 @@ xmlizePage -> 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) + += sattr "name" (T.unpack $ redirName page ) + += sattr "redirect" (T.unpack $ redirDest page ) + += sattr "isLocked" (yesOrNo $ redirIsLocked page) + += sattr "revision" (show $ redirRevision page) + += sattr "lastModified" (W3C.format lastMod) )) -<< () xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree @@ -250,10 +259,10 @@ xmlizePage -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page ( eelem "/" += ( eelem "page" - += sattr "name" (pageName page) + += sattr "name" (T.unpack $ pageName page) += sattr "type" (show $ entityType page) += ( case entityLanguage page of - Just x -> sattr "lang" x + Just x -> sattr "lang" (T.unpack $ CI.foldedCase x) Nothing -> none ) += ( case entityType page of @@ -265,10 +274,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 @@ -278,13 +286,13 @@ xmlizePage else selem "otherLang" [ eelem "link" - += sattr "lang" lang - += sattr "page" name - | (lang, name) <- M.toList (entityOtherLang page) ] + += sattr "lang" (T.unpack $ CI.foldedCase lang) + += sattr "page" (T.unpack name) + | (lang, name) ← M.toList (entityOtherLang page) ] ) += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ entityContent page) + += txt (L8.unpack $ encodeBase64LBS $ entityContent page) ) else ( eelem "textData" @@ -293,22 +301,23 @@ xmlizePage ) )) -<< () - -parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page +parseXmlizedPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (PageName, XmlTree) ⇝ Page parseXmlizedPage = proc (name, 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 - , redirUpdateInfo = updateInfo - }) - + → 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 = T.pack dest + , redirIsLocked = isLocked + , redirRevision = undefined + , redirLastMod = undefined + , redirUpdateInfo = updateInfo + } parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page parseEntity @@ -325,8 +334,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 @@ -343,45 +350,44 @@ 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 - if null mimeTypeStr then - guessMIMEType content - else - read mimeTypeStr - else - read mimeTypeStr - - returnA -< Entity { + = if isBinary then + if null mimeTypeStr then + guessMIMEType content + else + read mimeTypeStr + else + read mimeTypeStr + returnA ⤙ Entity { entityName = name , entityType = mimeType - , entityLanguage = lang + , entityLanguage = CI.mk ∘ T.pack <$> lang , entityIsTheme = isTheme , entityIsFeed = isFeed , entityIsLocked = isLocked - , entityIsBoring = isBoring , entityIsBinary = isBinary , entityRevision = undefined , entityLastMod = undefined , entitySummary = summary - , entityOtherLang = M.fromList otherLang + , entityOtherLang = M.fromList ((CI.mk ∘ T.pack ⁂ T.pack) <$> otherLang) , entityContent = content , entityUpdateInfo = updateInfo } - -parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo +parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo parseUpdateInfo = proc tree - -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree - oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo - oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo - returnA -< UpdateInfo { - uiOldRevision = oldRev - , uiOldName = oldName - } - - \ No newline at end of file + -> do uInfo ← getXPathTreesInDoc "/page/updateInfo" ⤙ tree + oldRev ← (getAttrValue0 "oldRevision" ⋙ arr read) ⤙ uInfo + oldName ← maybeA (getXPathTrees "/updateInfo/move/@from/text()" ⋙ getText) ⤙ uInfo + returnA ⤙ UpdateInfo { + uiOldRevision = oldRev + , uiOldName = T.pack <$> oldName + } + +dropWhitespace :: String -> String +{-# INLINE dropWhitespace #-} +dropWhitespace = filter ((¬) ∘ isSpace)