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