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