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