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 "revision" (show $ redirRevision page)
 244                        += sattr "lastModified" (formatW3CDateTime lastMod)
 245                      )) -<< ()
 246
 247       xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 248       xmlizeEntity
 249           = proc page
 250           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
 251                 ( eelem "/"
 252                   += ( eelem "page"
 253                        += sattr "name" (pageName page)
 254                        += sattr "type" (show $ entityType page)
 255                        += ( case entityLanguage page of
 256                               Just x  -> sattr "lang" x
 257                               Nothing -> none
 258                           )
 259                        += ( case entityType page of
 260                               MIMEType "text" "css" _
 261                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
 262                               MIMEType "text" "x-rakka" _
 263                                   -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
 264                               _
 265                                   -> none
 266                           )
 267                        += sattr "isLocked" (yesOrNo $ entityIsLocked page)
 268                        += sattr "isBinary" (yesOrNo $ entityIsBinary page)
 269                        += sattr "revision" (show $ entityRevision page)
 270                        += sattr "lastModified" (formatW3CDateTime lastMod)
 271                        += ( case entitySummary page of
 272                               Just s  -> eelem "summary" += txt s
 273                               Nothing -> none
 274                           )
 275                        += ( if M.null (entityOtherLang page) then
 276                                 none
 277                             else
 278                                 selem "otherLang"
 279                                           [ eelem "link"
 280                                             += sattr "lang" lang
 281                                             += sattr "page" name
 282                                                 | (lang, name) <- M.toList (entityOtherLang page) ]
 283                           )
 284                        += ( if entityIsBinary page then
 285                                 ( eelem "binaryData"
 286                                   += txt (B64.encode $ L.unpack $ entityContent page)
 287                                 )
 288                             else
 289                                 ( eelem "textData"
 290                                   += txt (UTF8.decode $ L.unpack $ entityContent page)
 291                                 )
 292                           )
 293                      )) -<< ()
 294
 295
 296 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 297 parseXmlizedPage
 298     = proc (name, tree)
 299     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 300           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 301           isLocked   <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 302                          >>> parseYesOrNo) -< tree
 303           case redirect of
 304             Nothing   -> parseEntity -< (name, tree)
 305             Just dest -> returnA     -< (Redirection {
 306                                            redirName       = name
 307                                          , redirDest       = dest
 308                                          , redirIsLocked   = isLocked
 309                                          , redirRevision   = undefined
 310                                          , redirLastMod    = undefined
 311                                          , redirUpdateInfo = updateInfo
 312                                          })
 313
 314
 315 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 316 parseEntity
 317     = proc (name, tree)
 318     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 319
 320           mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
 321
 322           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 323
 324           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 325                        >>> parseYesOrNo) -< tree
 326           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 327                        >>> parseYesOrNo) -< tree
 328           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 329                        >>> parseYesOrNo) -< tree
 330
 331           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 332                               >>> getText
 333                               >>> deleteIfEmpty)) -< tree
 334
 335           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 336                               >>>
 337                               (getAttrValue0 "lang"
 338                                &&&
 339                                getAttrValue0 "page")) -< tree
 340
 341           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 342           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 343
 344           let (isBinary, content)
 345                   = case (textData, binaryData) of
 346                       (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text )
 347                       (Nothing  , Just binary) -> (True , L.pack $ fromJust $ B64.decode binary)
 348                       _                        -> error "one of textData or binaryData is required"
 349               mimeType
 350                   =  if isBinary then
 351                          if null mimeTypeStr then
 352                              guessMIMEType content
 353                          else
 354                              read mimeTypeStr
 355                      else
 356                          read mimeTypeStr
 357
 358           returnA -< Entity {
 359                         entityName       = name
 360                       , entityType       = mimeType
 361                       , entityLanguage   = lang
 362                       , entityIsTheme    = isTheme
 363                       , entityIsFeed     = isFeed
 364                       , entityIsLocked   = isLocked
 365                       , entityIsBinary   = isBinary
 366                       , entityRevision   = undefined
 367                       , entityLastMod    = undefined
 368                       , entitySummary    = summary
 369                       , entityOtherLang  = M.fromList otherLang
 370                       , entityContent    = content
 371                       , entityUpdateInfo = updateInfo
 372                       }
 373
 374
 375 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 376 parseUpdateInfo
 377     = proc tree
 378     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 379           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 380           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 381           returnA -< UpdateInfo {
 382                         uiOldRevision = oldRev
 383                       , uiOldName     = oldName
 384                       }
 385
 386