Rakka/Page.hs

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