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       , entityIsBoring   :: !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 "isBoring" (yesOrNo $ entityIsBoring 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           case redirect of
 303             Nothing   -> parseEntity -< (name, tree)
 304             Just dest -> returnA     -< (Redirection {
 305                                            redirName       = name
 306                                          , redirDest       = dest
 307                                          , redirRevision   = undefined
 308                                          , redirLastMod    = undefined
 309                                          , redirUpdateInfo = updateInfo
 310                                          })
 311
 312
 313 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 314 parseEntity
 315     = proc (name, tree)
 316     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 317
 318           mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
 319
 320           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 321
 322           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 323                        >>> parseYesOrNo) -< tree
 324           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 325                        >>> parseYesOrNo) -< tree
 326           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 327                        >>> parseYesOrNo) -< tree
 328           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/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 $ 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                       , entityIsBoring   = isBoring
 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
 375
 376 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 377 parseUpdateInfo
 378     = proc tree
 379     -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
 380           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 381           oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
 382           returnA -< UpdateInfo {
 383                         uiOldRevision = oldRev
 384                       , uiOldName     = oldName
 385                       }
 386
 387