Rakka/Page.hs

   1 -- -*- coding: utf-8 -*-
   2 {-# LANGUAGE
   3     Arrows
   4   , UnicodeSyntax
   5   #-}
   6 module Rakka.Page
   7     ( PageName
   8     , Page(..)
   9     , UpdateInfo(..)
  10     , LanguageTag
  11     , LanguageName
  12
  13     , isRedirect
  14     , isEntity
  15
  16     , pageName
  17     , pageUpdateInfo
  18     , pageRevision
  19
  20     , encodePageName
  21     , decodePageName
  22
  23     , mkPageURI
  24     , mkPageFragmentURI
  25     , mkObjectURI
  26     , mkFragmentURI
  27     , mkAuxiliaryURI
  28     , mkFeedURI
  29     , mkRakkaURI
  30
  31     , xmlizePage
  32     , parseXmlizedPage
  33     )
  34     where
  35 import Control.Arrow
  36 import qualified Data.Ascii as Ascii
  37 import qualified Data.Text as T
  38 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  39 import qualified Data.ByteString.Lazy as L hiding (ByteString)
  40 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
  41 import Data.Char
  42 import Data.Map (Map)
  43 import qualified Data.Map as M
  44 import Data.Time
  45 import qualified Data.Time.W3C as W3C
  46 import Network.HTTP.Lucu hiding (redirect)
  47 import Network.URI hiding (fragment)
  48 import Rakka.Utils
  49 import Subversion.Types
  50 import System.FilePath.Posix
  51 import Text.XML.HXT.DOM.TypeDefs
  52 import Text.XML.HXT.XPath
  53 import Text.XML.HXT.Arrow.XmlArrow
  54 import Prelude.Unicode
  55
  56 type PageName = T.Text
  57
  58 type LanguageTag  = Ascii -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  59 type LanguageName = T.Text -- i.e. "日本語"
  60
  61
  62 data Page
  63     = Redirection {
  64         redirName       :: !PageName
  65       , redirDest       :: !PageName
  66       , redirIsLocked   :: !Bool
  67       , redirRevision   :: RevNum
  68       , redirLastMod    :: UTCTime
  69       , redirUpdateInfo :: Maybe UpdateInfo
  70       }
  71     | Entity {
  72         entityName       :: !PageName
  73       , entityType       :: !MIMEType
  74       , entityLanguage   :: !(Maybe LanguageTag)
  75       , entityIsTheme    :: !Bool     -- text/css 以外では無意味
  76       , entityIsFeed     :: !Bool     -- text/x-rakka 以外では無意味
  77       , entityIsLocked   :: !Bool
  78       , entityIsBinary   :: !Bool
  79       , entityRevision   :: RevNum
  80       , entityLastMod    :: UTCTime
  81       , entitySummary    :: !(Maybe String)
  82       , entityOtherLang  :: !(Map LanguageTag PageName)
  83       , entityContent    :: !Lazy.ByteString
  84       , entityUpdateInfo :: Maybe UpdateInfo
  85       }
  86     deriving (Show, Eq)
  87
  88
  89 data UpdateInfo
  90     = UpdateInfo {
  91         uiOldRevision :: !RevNum
  92       , uiOldName     :: !(Maybe PageName)
  93       }
  94     deriving (Show, Eq)
  95
  96
  97 isRedirect :: Page -> Bool
  98 isRedirect (Redirection _ _ _ _ _ _) = True
  99 isRedirect _                         = False
 100
 101
 102 isEntity :: Page -> Bool
 103 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
 104 isEntity _                                  = False
 105
 106
 107 pageName :: Page -> PageName
 108 pageName p
 109     | isRedirect p = redirName p
 110     | isEntity   p = entityName p
 111     | otherwise    = error "neither redirection nor entity"
 112
 113
 114 pageUpdateInfo :: Page -> Maybe UpdateInfo
 115 pageUpdateInfo p
 116     | isRedirect p = redirUpdateInfo p
 117     | isEntity   p = entityUpdateInfo p
 118     | otherwise    = error "neither redirection nor entity"
 119
 120
 121 pageRevision :: Page -> RevNum
 122 pageRevision p
 123     | isRedirect p = redirRevision p
 124     | isEntity   p = entityRevision p
 125     | otherwise    = error "neither redirection nor entity"
 126
 127
 128 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 129 encodePageName :: PageName -> FilePath
 130 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
 131     where
 132       fixPageName :: PageName -> PageName
 133       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 134
 135
 136 decodePageName :: FilePath -> PageName
 137 decodePageName = UTF8.decodeString . unEscapeString
 138
 139
 140 encodeFragment :: String -> String
 141 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 142
 143
 144 mkPageURI :: URI -> PageName -> URI
 145 mkPageURI baseURI name
 146     = baseURI {
 147         uriPath = uriPath baseURI </> encodePageName name <.> "html"
 148       }
 149
 150
 151 mkPageFragmentURI :: URI -> PageName -> String -> URI
 152 mkPageFragmentURI baseURI name fragment
 153     = baseURI {
 154         uriPath     = uriPath baseURI </> encodePageName name <.> "html"
 155       , uriFragment = ('#' : encodeFragment fragment)
 156       }
 157
 158
 159 mkFragmentURI :: String -> URI
 160 mkFragmentURI fragment
 161     = nullURI {
 162         uriFragment = ('#' : encodeFragment fragment)
 163       }
 164
 165
 166 mkObjectURI :: URI -> PageName -> URI
 167 mkObjectURI baseURI name
 168     = mkAuxiliaryURI baseURI ["object"] name
 169
 170
 171 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 172 mkAuxiliaryURI baseURI basePath name
 173     = baseURI {
 174         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 175       }
 176
 177
 178 mkFeedURI :: URI -> PageName -> URI
 179 mkFeedURI baseURI name
 180     = baseURI {
 181         uriPath = uriPath baseURI </> encodePageName name <.> "rdf"
 182       }
 183
 184
 185 mkRakkaURI :: PageName -> URI
 186 mkRakkaURI name = URI {
 187                     uriScheme    = "rakka:"
 188                   , uriAuthority = Nothing
 189                   , uriPath      = encodePageName name
 190                   , uriQuery     = ""
 191                   , uriFragment  = ""
 192                   }
 193
 194
 195 {-
 196   <page name="Foo/Bar"
 197         type="text/x-rakka"
 198         lang="ja"            -- 存在しない場合もある
 199         isTheme="no"         -- text/css の場合のみ存在
 200         isFeed="no"          -- text/x-rakka の場合のみ存在
 201         isLocked="no"
 202         isBinary="no"
 203         revision="112"
 204         lastModified="2000-01-01T00:00:00">
 205
 206     <summary>
 207         blah blah...
 208     </summary> -- 存在しない場合もある
 209
 210     <otherLang> -- 存在しない場合もある
 211       <link lang="ja" page="Bar/Baz" />
 212     </otherLang>
 213
 214     <!-- 何れか一方のみ -->
 215     <textData>
 216       blah blah...
 217     </textData>
 218     <binaryData>
 219       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
 220     </binaryData>
 221   </page>
 222
 223   <page name="Foo/Bar"
 224         redirect="Baz"
 225         revision="112"
 226         lastModified="2000-01-01T00:00:00" />
 227 -}
 228 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 229 xmlizePage
 230     = proc page
 231     -> if isRedirect page then
 232            xmlizeRedirection -< page
 233        else
 234            xmlizeEntity -< page
 235     where
 236       xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 237       xmlizeRedirection
 238           = proc page
 239           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
 240                 ( eelem "/"
 241                   += ( eelem "page"
 242                        += sattr "name"     (redirName page)
 243                        += sattr "redirect" (redirDest page)
 244                        += sattr "isLocked" (yesOrNo $ redirIsLocked page)
 245                        += sattr "revision" (show $ redirRevision page)
 246                        += sattr "lastModified" (W3C.format lastMod)
 247                      )) -<< ()
 248
 249       xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 250       xmlizeEntity
 251           = proc page
 252           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
 253                 ( eelem "/"
 254                   += ( eelem "page"
 255                        += sattr "name" (pageName page)
 256                        += sattr "type" (show $ entityType page)
 257                        += ( case entityLanguage page of
 258                               Just x  -> sattr "lang" x
 259                               Nothing -> none
 260                           )
 261                        += ( case entityType page of
 262                               MIMEType "text" "css" _
 263                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
 264                               MIMEType "text" "x-rakka" _
 265                                   -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
 266                               _
 267                                   -> none
 268                           )
 269                        += sattr "isLocked" (yesOrNo $ entityIsLocked page)
 270                        += sattr "isBinary" (yesOrNo $ entityIsBinary page)
 271                        += sattr "revision" (show $ entityRevision page)
 272                        += sattr "lastModified" (W3C.format lastMod)
 273                        += ( case entitySummary page of
 274                               Just s  -> eelem "summary" += txt s
 275                               Nothing -> none
 276                           )
 277                        += ( if M.null (entityOtherLang page) then
 278                                 none
 279                             else
 280                                 selem "otherLang"
 281                                           [ eelem "link"
 282                                             += sattr "lang" lang
 283                                             += sattr "page" name
 284                                                 | (lang, name) <- M.toList (entityOtherLang page) ]
 285                           )
 286                        += ( if entityIsBinary page then
 287                                 ( eelem "binaryData"
 288                                   += txt (L8.unpack $ encodeBase64LBS $ entityContent page)
 289                                 )
 290                             else
 291                                 ( eelem "textData"
 292                                   += txt (UTF8.decode $ L.unpack $ entityContent page)
 293                                 )
 294                           )
 295                      )) -<< ()
 296
 297
 298 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 299 parseXmlizedPage
 300     = proc (name, tree)
 301     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 302           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 303           isLocked   <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 304                          >>> parseYesOrNo) -< tree
 305           case redirect of
 306             Nothing   -> parseEntity -< (name, tree)
 307             Just dest -> returnA     -< (Redirection {
 308                                            redirName       = name
 309                                          , redirDest       = dest
 310                                          , redirIsLocked   = isLocked
 311                                          , redirRevision   = undefined
 312                                          , redirLastMod    = undefined
 313                                          , redirUpdateInfo = updateInfo
 314                                          })
 315
 316
 317 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 318 parseEntity
 319     = proc (name, tree)
 320     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 321
 322           mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
 323
 324           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 325
 326           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 327                        >>> parseYesOrNo) -< tree
 328           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 329                        >>> parseYesOrNo) -< tree
 330           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 331                        >>> parseYesOrNo) -< tree
 332
 333           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 334                               >>> getText
 335                               >>> deleteIfEmpty)) -< tree
 336
 337           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 338                               >>>
 339                               (getAttrValue0 "lang"
 340                                &&&
 341                                getAttrValue0 "page")) -< tree
 342
 343           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 344           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 345
 346           let (isBinary, content)
 347                   = case (textData, binaryData) of
 348                       (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text)
 349                       (Nothing  , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace binary)
 350                       _                        -> error "one of textData or binaryData is required"
 351               mimeType
 352                   =  if isBinary then
 353                          if null mimeTypeStr then
 354                              guessMIMEType content
 355                          else
 356                              read mimeTypeStr
 357                      else
 358                          read mimeTypeStr
 359
 360           returnA -< Entity {
 361                         entityName       = name
 362                       , entityType       = mimeType
 363                       , entityLanguage   = lang
 364                       , entityIsTheme    = isTheme
 365                       , entityIsFeed     = isFeed
 366                       , entityIsLocked   = isLocked
 367                       , entityIsBinary   = isBinary
 368                       , entityRevision   = undefined
 369                       , entityLastMod    = undefined
 370                       , entitySummary    = summary
 371                       , entityOtherLang  = M.fromList otherLang
 372                       , entityContent    = content
 373                       , entityUpdateInfo = updateInfo
 374                       }
 375
 376 dropWhitespace :: String -> String
 377 {-# INLINE dropWhitespace #-}
 378 dropWhitespace = filter ((¬) ∘ isSpace)
 379
 380 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 381 parseUpdateInfo
 382     = proc tree
 383     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 384           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 385           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 386           returnA -< UpdateInfo {
 387                         uiOldRevision = oldRev
 388                       , uiOldName     = oldName
 389                       }