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