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