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       , redirRevision   :: RevNum
  64       , redirLastMod    :: UTCTime
  65       , redirUpdateInfo :: Maybe UpdateInfo
  66       }
  67     | Entity {
  68         entityName       :: !PageName
  69       , entityType       :: !MIMEType
  70       , entityLanguage   :: !(Maybe LanguageTag)
  71       , entityIsTheme    :: !Bool     -- text/css 以外では無意味
  72       , entityIsFeed     :: !Bool     -- text/x-rakka 以外では無意味
  73       , entityIsLocked   :: !Bool
  74       , entityIsBinary   :: !Bool
  75       , entityRevision   :: RevNum
  76       , entityLastMod    :: UTCTime
  77       , entitySummary    :: !(Maybe String)
  78       , entityOtherLang  :: !(Map LanguageTag PageName)
  79       , entityContent    :: !Lazy.ByteString
  80       , entityUpdateInfo :: Maybe UpdateInfo
  81       }
  82     deriving (Show, Eq)
  83
  84
  85 data UpdateInfo
  86     = UpdateInfo {
  87         uiOldRevision :: !RevNum
  88       , uiOldName     :: !(Maybe PageName)
  89       }
  90     deriving (Show, Eq)
  91
  92
  93 isRedirect :: Page -> Bool
  94 isRedirect (Redirection _ _ _ _ _) = True
  95 isRedirect _                       = False
  96
  97
  98 isEntity :: Page -> Bool
  99 isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
 100 isEntity _                                  = False
 101
 102
 103 pageName :: Page -> PageName
 104 pageName p
 105     | isRedirect p = redirName p
 106     | isEntity   p = entityName p
 107     | otherwise    = error "neither redirection nor entity"
 108
 109
 110 pageUpdateInfo :: Page -> Maybe UpdateInfo
 111 pageUpdateInfo p
 112     | isRedirect p = redirUpdateInfo p
 113     | isEntity   p = entityUpdateInfo p
 114     | otherwise    = error "neither redirection nor entity"
 115
 116
 117 pageRevision :: Page -> RevNum
 118 pageRevision p
 119     | isRedirect p = redirRevision p
 120     | isEntity   p = entityRevision p
 121     | otherwise    = error "neither redirection nor entity"
 122
 123
 124 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 125 encodePageName :: PageName -> FilePath
 126 encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
 127     where
 128       fixPageName :: PageName -> PageName
 129       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
 130
 131
 132 isSafeChar :: Char -> Bool
 133 isSafeChar c
 134     | c == '/'            = True
 135     | isReserved c        = False
 136     | c > ' ' && c <= '~' = True
 137     | otherwise           = False
 138
 139
 140 -- URI unescape して UTF-8 から decode する。
 141 decodePageName :: FilePath -> PageName
 142 decodePageName = UTF8.decodeString . unEscapeString
 143
 144
 145 encodeFragment :: String -> String
 146 encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 147
 148
 149 mkPageURI :: URI -> PageName -> URI
 150 mkPageURI baseURI name
 151     = baseURI {
 152         uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 153       }
 154
 155
 156 mkPageFragmentURI :: URI -> PageName -> String -> URI
 157 mkPageFragmentURI baseURI name fragment
 158     = baseURI {
 159         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 160       , uriFragment = ('#' : encodeFragment fragment)
 161       }
 162
 163
 164 mkFragmentURI :: String -> URI
 165 mkFragmentURI fragment
 166     = nullURI {
 167         uriFragment = ('#' : encodeFragment fragment)
 168       }
 169
 170
 171 mkObjectURI :: URI -> PageName -> URI
 172 mkObjectURI baseURI name
 173     = mkAuxiliaryURI baseURI ["object"] name
 174
 175
 176 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 177 mkAuxiliaryURI baseURI basePath name
 178     = baseURI {
 179         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 180       }
 181
 182
 183 mkRakkaURI :: PageName -> URI
 184 mkRakkaURI name = URI {
 185                     uriScheme    = "rakka:"
 186                   , uriAuthority = Nothing
 187                   , uriPath      = encodePageName name
 188                   , uriQuery     = ""
 189                   , uriFragment  = ""
 190                   }
 191
 192
 193 {-
 194   <page name="Foo/Bar"
 195         type="text/x-rakka"
 196         lang="ja"            -- 存在しない場合もある
 197         isTheme="no"         -- text/css の場合のみ存在
 198         isFeed="no"          -- text/x-rakka の場合のみ存在
 199         isLocked="no"
 200         isBinary="no"
 201         revision="112"
 202         lastModified="2000-01-01T00:00:00">
 203
 204     <summary>
 205         blah blah...
 206     </summary> -- 存在しない場合もある
 207
 208     <otherLang> -- 存在しない場合もある
 209       <link lang="ja" page="Bar/Baz" />
 210     </otherLang>
 211
 212     <!-- 何れか一方のみ -->
 213     <textData>
 214       blah blah...
 215     </textData>
 216     <binaryData>
 217       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
 218     </binaryData>
 219   </page>
 220
 221   <page name="Foo/Bar"
 222         redirect="Baz"
 223         revision="112"
 224         lastModified="2000-01-01T00:00:00" />
 225 -}
 226 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 227 xmlizePage
 228     = proc page
 229     -> if isRedirect page then
 230            xmlizeRedirection -< page
 231        else
 232            xmlizeEntity -< page
 233     where
 234       xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 235       xmlizeRedirection
 236           = proc page
 237           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
 238                 ( eelem "/"
 239                   += ( eelem "page"
 240                        += sattr "name"     (redirName page)
 241                        += sattr "redirect" (redirDest page)
 242                        += sattr "revision" (show $ redirRevision page)
 243                        += sattr "lastModified" (formatW3CDateTime lastMod)
 244                      )) -<< ()
 245
 246       xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 247       xmlizeEntity
 248           = proc page
 249           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
 250                 ( eelem "/"
 251                   += ( eelem "page"
 252                        += sattr "name" (pageName page)
 253                        += sattr "type" (show $ entityType page)
 254                        += ( case entityLanguage page of
 255                               Just x  -> sattr "lang" x
 256                               Nothing -> none
 257                           )
 258                        += ( case entityType page of
 259                               MIMEType "text" "css" _
 260                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
 261                               MIMEType "text" "x-rakka" _
 262                                   -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
 263                               _
 264                                   -> none
 265                           )
 266                        += sattr "isLocked" (yesOrNo $ entityIsLocked page)
 267                        += sattr "isBinary" (yesOrNo $ entityIsBinary page)
 268                        += sattr "revision" (show $ entityRevision page)
 269                        += sattr "lastModified" (formatW3CDateTime lastMod)
 270                        += ( case entitySummary page of
 271                               Just s  -> eelem "summary" += txt s
 272                               Nothing -> none
 273                           )
 274                        += ( if M.null (entityOtherLang page) then
 275                                 none
 276                             else
 277                                 selem "otherLang"
 278                                           [ eelem "link"
 279                                             += sattr "lang" lang
 280                                             += sattr "page" name
 281                                                 | (lang, name) <- M.toList (entityOtherLang page) ]
 282                           )
 283                        += ( if entityIsBinary page then
 284                                 ( eelem "binaryData"
 285                                   += txt (B64.encode $ L.unpack $ entityContent page)
 286                                 )
 287                             else
 288                                 ( eelem "textData"
 289                                   += txt (UTF8.decode $ L.unpack $ entityContent page)
 290                                 )
 291                           )
 292                      )) -<< ()
 293
 294
 295 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 296 parseXmlizedPage
 297     = proc (name, tree)
 298     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 299           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 300           case redirect of
 301             Nothing   -> parseEntity -< (name, tree)
 302             Just dest -> returnA     -< (Redirection {
 303                                            redirName       = name
 304                                          , redirDest       = dest
 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 , L.pack $ B64.decode 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
 370
 371 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 372 parseUpdateInfo
 373     = proc tree
 374     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 375           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 376           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 377           returnA -< UpdateInfo {
 378                         uiOldRevision = oldRev
 379                       , uiOldName     = oldName
 380                       }
 381
 382