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 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 235 xmlizePage
 236     = proc page
 237     -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
 238           ( eelem "/"
 239             += ( eelem "page"
 240                  += sattr "name" (pageName page)
 241                  += sattr "type" (show $ entityType page)
 242                  += ( case entityLanguage page of
 243                         Just x  -> sattr "lang" x
 244                         Nothing -> none
 245                     )
 246                  += ( case entityFileName page of
 247                         Just x  -> sattr "fileName" x
 248                         Nothing -> none
 249                     )
 250                  += ( case entityType page of
 251                         MIMEType "text" "css" _
 252                             -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
 253                         MIMEType "text" "x-rakka" _
 254                             -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
 255                         _
 256                             -> none
 257                     )
 258                  += sattr "isLocked" (yesOrNo $ entityIsLocked page)
 259                  += sattr "isBoring" (yesOrNo $ entityIsBoring page)
 260                  += sattr "isBinary" (yesOrNo $ entityIsBinary page)
 261                  += sattr "revision" (show $ entityRevision page)
 262                  += sattr "lastModified" (formatW3CDateTime lastMod)
 263                  += ( case entitySummary page of
 264                         Just s  -> eelem "summary" += txt s
 265                         Nothing -> none
 266                     )
 267                  += ( if M.null (entityOtherLang page) then
 268                           none
 269                       else
 270                           selem "otherLang"
 271                                     [ eelem "link"
 272                                       += sattr "lang" lang
 273                                       += sattr "page" name
 274                                           | (lang, name) <- M.toList (entityOtherLang page) ]
 275                     )
 276                  += ( if entityIsBinary page then
 277                           ( eelem "binaryData"
 278                             += txt (B64.encode $ L.unpack $ entityContent page)
 279                           )
 280                       else
 281                           ( eelem "textData"
 282                             += txt (decode $ L.unpack $ entityContent page)
 283                           )
 284                     )
 285                )) -<< ()
 286
 287
 288 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 289 parseXmlizedPage
 290     = proc (name, tree)
 291     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 292           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 293           case redirect of
 294             Nothing   -> parseEntity -< (name, tree)
 295             Just dest -> returnA     -< (Redirection {
 296                                            redirName       = name
 297                                          , redirDest       = dest
 298                                          , redirRevision   = undefined
 299                                          , redirLastMod    = undefined
 300                                          , redirUpdateInfo = updateInfo
 301                                          })
 302
 303
 304 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 305 parseEntity
 306     = proc (name, tree)
 307     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 308
 309           mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
 310                        >>> arr read) -< tree
 311
 312           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 313           fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
 314
 315           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 316                        >>> parseYesOrNo) -< tree
 317           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 318                        >>> parseYesOrNo) -< tree
 319           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 320                        >>> parseYesOrNo) -< tree
 321           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
 322                        >>> parseYesOrNo) -< tree
 323
 324           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 325                               >>> getText
 326                               >>> deleteIfEmpty)) -< tree
 327
 328           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 329                               >>>
 330                               (getAttrValue0 "lang"
 331                                &&&
 332                                getAttrValue0 "page")) -< tree
 333
 334           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 335           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 336
 337           let (isBinary, content)
 338                   = case (textData, binaryData) of
 339                       (Just text, Nothing    ) -> (False, L.pack $ encode text      )
 340                       (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
 341                       _                        -> error "one of textData or binaryData is required"
 342
 343           returnA -< Entity {
 344                         entityName       = name
 345                       , entityType       = mimeType
 346                       , entityLanguage   = lang
 347                       , entityFileName   = fileName
 348                       , entityIsTheme    = isTheme
 349                       , entityIsFeed     = isFeed
 350                       , entityIsLocked   = isLocked
 351                       , entityIsBoring   = isBoring
 352                       , entityIsBinary   = isBinary
 353                       , entityRevision   = undefined
 354                       , entityLastMod    = undefined
 355                       , entitySummary    = summary
 356                       , entityOtherLang  = M.fromList otherLang
 357                       , entityContent    = content
 358                       , entityUpdateInfo = updateInfo
 359                       }
 360
 361
 362 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 363 parseUpdateInfo
 364     = proc tree
 365     -> do uInfo   <- getXPathTreesInDoc "/*/updateInfo" -< tree
 366           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
 367           oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo
 368           returnA -< UpdateInfo {
 369                         uiOldRevision = oldRev
 370                       , uiOldName     = oldName
 371                       }
 372
 373