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