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