Rakka/Page.hs

   1 module Rakka.Page
   2     ( PageName
   3     , Page(..)
   4     , UpdateInfo(..)
   5     , LanguageTag
   6     , LanguageName
   7
   8     , isRedirect
   9     , isEntity
  10
  11     , pageName
  12     , pageUpdateInfo
  13     , pageRevision
  14
  15     , encodePageName
  16     , decodePageName
  17
  18     , mkPageURI
  19     , mkPageFragmentURI
  20     , mkObjectURI
  21     , mkFragmentURI
  22     , mkAuxiliaryURI
  23     , mkFeedURI
  24     , mkRakkaURI
  25
  26     , xmlizePage
  27     , parseXmlizedPage
  28     )
  29     where
  30
  31 import qualified Codec.Binary.UTF8.String as UTF8
  32 import           Control.Arrow
  33 import           Control.Arrow.ArrowIO
  34 import           Control.Arrow.ArrowList
  35 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  36 import qualified Data.ByteString.Lazy as L hiding (ByteString)
  37 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
  38 import           Data.Char
  39 import           Data.Map (Map)
  40 import qualified Data.Map as M
  41 import           Data.Maybe
  42 import           Data.Time
  43 import           Network.HTTP.Lucu hiding (redirect)
  44 import           Network.URI hiding (fragment)
  45 import           OpenSSL.EVP.Base64
  46 import           Rakka.Utils
  47 import           Rakka.W3CDateTime
  48 import           Subversion.Types
  49 import           System.FilePath.Posix
  50 import           Text.XML.HXT.Arrow.XmlArrow
  51 import           Text.XML.HXT.Arrow.XmlNodeSet
  52 import           Text.XML.HXT.DOM.TypeDefs
  53
  54
  55 type PageName = String
  56
  57 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  58 type LanguageName = String -- i.e. "日本語"
  59
  60
  61 data Page
  62     = Redirection {
  63         redirName       :: !PageName
  64       , redirDest       :: !PageName
  65       , redirIsLocked   :: !Bool
  66       , redirRevision   :: RevNum
  67       , redirLastMod    :: UTCTime
  68       , redirUpdateInfo :: Maybe UpdateInfo
  69       }
  70     | Entity {
  71         entityName       :: !PageName
  72       , entityType       :: !MIMEType
  73       , entityLanguage   :: !(Maybe LanguageTag)
  74       , entityIsTheme    :: !Bool     -- text/css 以外では無意味
  75       , entityIsFeed     :: !Bool     -- text/x-rakka 以外では無意味
  76       , entityIsLocked   :: !Bool
  77       , entityIsBinary   :: !Bool
  78       , entityRevision   :: RevNum
  79       , entityLastMod    :: UTCTime
  80       , entitySummary    :: !(Maybe String)
  81       , entityOtherLang  :: !(Map LanguageTag PageName)
  82       , entityContent    :: !Lazy.ByteString
  83       , entityUpdateInfo :: Maybe UpdateInfo
  84       }
  85     deriving (Show, Eq)
  86
  87
  88 data UpdateInfo
  89     = UpdateInfo {
  90         uiOldRevision :: !RevNum
  91       , uiOldName     :: !(Maybe PageName)
  92       }
  93     deriving (Show, Eq)
  94
  95
  96 isRedirect :: Page -> Bool
  97 isRedirect (Redirection _ _ _ _ _ _) = True
  98 isRedirect _                         = False
  99
 100
 101 isEntity :: Page -> Bool
 102 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
 103 isEntity _                                  = False
 104
 105
 106 pageName :: Page -> PageName
 107 pageName p
 108     | isRedirect p = redirName p
 109     | isEntity   p = entityName p
 110     | otherwise    = error "neither redirection nor entity"
 111
 112
 113 pageUpdateInfo :: Page -> Maybe UpdateInfo
 114 pageUpdateInfo p
 115     | isRedirect p = redirUpdateInfo p
 116     | isEntity   p = entityUpdateInfo p
 117     | otherwise    = error "neither redirection nor entity"
 118
 119
 120 pageRevision :: Page -> RevNum
 121 pageRevision p
 122     | isRedirect p = redirRevision p
 123     | isEntity   p = entityRevision p
 124     | otherwise    = error "neither redirection nor entity"
 125
 126
 127 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 128 encodePageName :: PageName -> FilePath
 129 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
 130     where
 131       fixPageName :: PageName -> PageName
 132       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 133
 134
 135 -- URI unescape して UTF-8 から decode する。
 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" (formatW3CDateTime 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" (formatW3CDateTime 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     where
 376       dropWhitespace :: String -> String
 377       dropWhitespace [] = []
 378       dropWhitespace (x:xs)
 379           | x == ' ' || x == '\t' || x == '\n'
 380               = dropWhitespace xs
 381           | otherwise
 382               = x : dropWhitespace xs
 383
 384
 385 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 386 parseUpdateInfo
 387     = proc tree
 388     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 389           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 390           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 391           returnA -< UpdateInfo {
 392                         uiOldRevision = oldRev
 393                       , uiOldName     = oldName
 394                       }
 395
 396