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