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     , isSafeChar
  16     , encodePageName
  17     , decodePageName
  18
  19     , mkPageURI
  20     , mkPageFragmentURI
  21     , mkObjectURI
  22     , mkFragmentURI
  23     , mkAuxiliaryURI
  24     , mkFeedURI
  25     , mkRakkaURI
  26
  27     , xmlizePage
  28     , parseXmlizedPage
  29     )
  30     where
  31
  32 import qualified Codec.Binary.UTF8.String as UTF8
  33 import           Control.Arrow
  34 import           Control.Arrow.ArrowIO
  35 import           Control.Arrow.ArrowList
  36 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  37 import qualified Data.ByteString.Lazy as L hiding (ByteString)
  38 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
  39 import           Data.Char
  40 import           Data.Map (Map)
  41 import qualified Data.Map as M
  42 import           Data.Maybe
  43 import           Data.Time
  44 import           Network.HTTP.Lucu hiding (redirect)
  45 import           Network.URI hiding (fragment)
  46 import           OpenSSL.EVP.Base64
  47 import           Rakka.Utils
  48 import           Rakka.W3CDateTime
  49 import           Subversion.Types
  50 import           System.FilePath.Posix
  51 import           Text.XML.HXT.Arrow.XmlArrow
  52 import           Text.XML.HXT.Arrow.XmlNodeSet
  53 import           Text.XML.HXT.DOM.TypeDefs
  54
  55
  56 type PageName = String
  57
  58 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  59 type LanguageName = String -- 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 isSafeChar :: Char -> Bool
 137 isSafeChar c
 138     | c == '/'            = True
 139     | isReserved c        = False
 140     | c > ' ' && c <= '~' = True
 141     | otherwise           = False
 142
 143
 144 -- URI unescape して UTF-8 から decode する。
 145 decodePageName :: FilePath -> PageName
 146 decodePageName = UTF8.decodeString . unEscapeString
 147
 148
 149 encodeFragment :: String -> String
 150 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 151
 152
 153 mkPageURI :: URI -> PageName -> URI
 154 mkPageURI baseURI name
 155     = baseURI {
 156         uriPath = uriPath baseURI </> encodePageName name <.> "html"
 157       }
 158
 159
 160 mkPageFragmentURI :: URI -> PageName -> String -> URI
 161 mkPageFragmentURI baseURI name fragment
 162     = baseURI {
 163         uriPath     = uriPath baseURI </> encodePageName name <.> "html"
 164       , uriFragment = ('#' : encodeFragment fragment)
 165       }
 166
 167
 168 mkFragmentURI :: String -> URI
 169 mkFragmentURI fragment
 170     = nullURI {
 171         uriFragment = ('#' : encodeFragment fragment)
 172       }
 173
 174
 175 mkObjectURI :: URI -> PageName -> URI
 176 mkObjectURI baseURI name
 177     = mkAuxiliaryURI baseURI ["object"] name
 178
 179
 180 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 181 mkAuxiliaryURI baseURI basePath name
 182     = baseURI {
 183         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 184       }
 185
 186
 187 mkFeedURI :: URI -> PageName -> URI
 188 mkFeedURI baseURI name
 189     = baseURI {
 190         uriPath = uriPath baseURI </> encodePageName name <.> "rdf"
 191       }
 192
 193
 194 mkRakkaURI :: PageName -> URI
 195 mkRakkaURI name = URI {
 196                     uriScheme    = "rakka:"
 197                   , uriAuthority = Nothing
 198                   , uriPath      = encodePageName name
 199                   , uriQuery     = ""
 200                   , uriFragment  = ""
 201                   }
 202
 203
 204 {-
 205   <page name="Foo/Bar"
 206         type="text/x-rakka"
 207         lang="ja"            -- 存在しない場合もある
 208         isTheme="no"         -- text/css の場合のみ存在
 209         isFeed="no"          -- text/x-rakka の場合のみ存在
 210         isLocked="no"
 211         isBinary="no"
 212         revision="112"
 213         lastModified="2000-01-01T00:00:00">
 214
 215     <summary>
 216         blah blah...
 217     </summary> -- 存在しない場合もある
 218
 219     <otherLang> -- 存在しない場合もある
 220       <link lang="ja" page="Bar/Baz" />
 221     </otherLang>
 222
 223     <!-- 何れか一方のみ -->
 224     <textData>
 225       blah blah...
 226     </textData>
 227     <binaryData>
 228       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
 229     </binaryData>
 230   </page>
 231
 232   <page name="Foo/Bar"
 233         redirect="Baz"
 234         revision="112"
 235         lastModified="2000-01-01T00:00:00" />
 236 -}
 237 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 238 xmlizePage
 239     = proc page
 240     -> if isRedirect page then
 241            xmlizeRedirection -< page
 242        else
 243            xmlizeEntity -< page
 244     where
 245       xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 246       xmlizeRedirection
 247           = proc page
 248           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
 249                 ( eelem "/"
 250                   += ( eelem "page"
 251                        += sattr "name"     (redirName page)
 252                        += sattr "redirect" (redirDest page)
 253                        += sattr "isLocked" (yesOrNo $ redirIsLocked page)
 254                        += sattr "revision" (show $ redirRevision page)
 255                        += sattr "lastModified" (formatW3CDateTime lastMod)
 256                      )) -<< ()
 257
 258       xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 259       xmlizeEntity
 260           = proc page
 261           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
 262                 ( eelem "/"
 263                   += ( eelem "page"
 264                        += sattr "name" (pageName page)
 265                        += sattr "type" (show $ entityType page)
 266                        += ( case entityLanguage page of
 267                               Just x  -> sattr "lang" x
 268                               Nothing -> none
 269                           )
 270                        += ( case entityType page of
 271                               MIMEType "text" "css" _
 272                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
 273                               MIMEType "text" "x-rakka" _
 274                                   -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
 275                               _
 276                                   -> none
 277                           )
 278                        += sattr "isLocked" (yesOrNo $ entityIsLocked page)
 279                        += sattr "isBinary" (yesOrNo $ entityIsBinary page)
 280                        += sattr "revision" (show $ entityRevision page)
 281                        += sattr "lastModified" (formatW3CDateTime lastMod)
 282                        += ( case entitySummary page of
 283                               Just s  -> eelem "summary" += txt s
 284                               Nothing -> none
 285                           )
 286                        += ( if M.null (entityOtherLang page) then
 287                                 none
 288                             else
 289                                 selem "otherLang"
 290                                           [ eelem "link"
 291                                             += sattr "lang" lang
 292                                             += sattr "page" name
 293                                                 | (lang, name) <- M.toList (entityOtherLang page) ]
 294                           )
 295                        += ( if entityIsBinary page then
 296                                 ( eelem "binaryData"
 297                                   += txt (L8.unpack $ encodeBase64LBS $ entityContent page)
 298                                 )
 299                             else
 300                                 ( eelem "textData"
 301                                   += txt (UTF8.decode $ L.unpack $ entityContent page)
 302                                 )
 303                           )
 304                      )) -<< ()
 305
 306
 307 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 308 parseXmlizedPage
 309     = proc (name, tree)
 310     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 311           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 312           isLocked   <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 313                          >>> parseYesOrNo) -< tree
 314           case redirect of
 315             Nothing   -> parseEntity -< (name, tree)
 316             Just dest -> returnA     -< (Redirection {
 317                                            redirName       = name
 318                                          , redirDest       = dest
 319                                          , redirIsLocked   = isLocked
 320                                          , redirRevision   = undefined
 321                                          , redirLastMod    = undefined
 322                                          , redirUpdateInfo = updateInfo
 323                                          })
 324
 325
 326 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 327 parseEntity
 328     = proc (name, tree)
 329     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 330
 331           mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
 332
 333           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 334
 335           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 336                        >>> parseYesOrNo) -< tree
 337           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 338                        >>> parseYesOrNo) -< tree
 339           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 340                        >>> parseYesOrNo) -< tree
 341
 342           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 343                               >>> getText
 344                               >>> deleteIfEmpty)) -< tree
 345
 346           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 347                               >>>
 348                               (getAttrValue0 "lang"
 349                                &&&
 350                                getAttrValue0 "page")) -< tree
 351
 352           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 353           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 354
 355           let (isBinary, content)
 356                   = case (textData, binaryData) of
 357                       (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text)
 358                       (Nothing  , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace binary)
 359                       _                        -> error "one of textData or binaryData is required"
 360               mimeType
 361                   =  if isBinary then
 362                          if null mimeTypeStr then
 363                              guessMIMEType content
 364                          else
 365                              read mimeTypeStr
 366                      else
 367                          read mimeTypeStr
 368
 369           returnA -< Entity {
 370                         entityName       = name
 371                       , entityType       = mimeType
 372                       , entityLanguage   = lang
 373                       , entityIsTheme    = isTheme
 374                       , entityIsFeed     = isFeed
 375                       , entityIsLocked   = isLocked
 376                       , entityIsBinary   = isBinary
 377                       , entityRevision   = undefined
 378                       , entityLastMod    = undefined
 379                       , entitySummary    = summary
 380                       , entityOtherLang  = M.fromList otherLang
 381                       , entityContent    = content
 382                       , entityUpdateInfo = updateInfo
 383                       }
 384     where
 385       dropWhitespace :: String -> String
 386       dropWhitespace [] = []
 387       dropWhitespace (x:xs)
 388           | x == ' ' || x == '\t' || x == '\n'
 389               = dropWhitespace xs
 390           | otherwise
 391               = x : dropWhitespace xs
 392
 393
 394 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 395 parseUpdateInfo
 396     = proc tree
 397     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 398           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 399           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 400           returnA -< UpdateInfo {
 401                         uiOldRevision = oldRev
 402                       , uiOldName     = oldName
 403                       }
 404
 405