Rakka/Page.hs

   1 module Rakka.Page
   2     ( PageName
   3     , Page(..)
   4     , LanguageTag
   5     , LanguageName
   6
   7     , encodePageName
   8     , decodePageName
   9
  10     , pageFileName'
  11     , defaultFileName
  12
  13     , mkPageURI
  14     , mkPageFragmentURI
  15     , mkObjectURI
  16     , mkFragmentURI
  17     , mkAuxiliaryURI
  18     , mkRakkaURI
  19
  20     , xmlizePage
  21     , parseXmlizedPage
  22     )
  23     where
  24
  25 import qualified Codec.Binary.Base64 as B64
  26 import           Codec.Binary.UTF8.String
  27 import           Control.Arrow
  28 import           Control.Arrow.ArrowIO
  29 import           Control.Arrow.ArrowList
  30 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  31 import qualified Data.ByteString.Lazy as L hiding (ByteString)
  32 import           Data.Char
  33 import           Data.Map (Map)
  34 import qualified Data.Map as M
  35 import           Data.Maybe
  36 import           Data.Time
  37 import           Network.HTTP.Lucu hiding (redirect)
  38 import           Network.URI hiding (fragment)
  39 import           Rakka.Utils
  40 import           Rakka.W3CDateTime
  41 import           Subversion.Types
  42 import           System.FilePath.Posix
  43 import           Text.XML.HXT.Arrow.XmlArrow
  44 import           Text.XML.HXT.Arrow.XmlNodeSet
  45 import           Text.XML.HXT.DOM.TypeDefs
  46
  47
  48 type PageName = String
  49
  50 type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
  51 type LanguageName = String -- i.e. "日本語"
  52
  53
  54 data Page
  55     = Redirection {
  56         redirName     :: !PageName
  57       , redirDest     :: !PageName
  58       , redirRevision :: RevNum
  59       , redirLastMod  :: UTCTime
  60       }
  61     | Entity {
  62         pageName      :: !PageName
  63       , pageType      :: !MIMEType
  64       , pageLanguage  :: !(Maybe LanguageTag)
  65       , pageFileName  :: !(Maybe String)
  66       , pageIsTheme   :: !Bool     -- text/css 以外では無意味
  67       , pageIsFeed    :: !Bool     -- text/x-rakka 以外では無意味
  68       , pageIsLocked  :: !Bool
  69       , pageIsBoring  :: !Bool
  70       , pageIsBinary  :: !Bool
  71       , pageRevision  :: RevNum
  72       , pageLastMod   :: UTCTime
  73       , pageSummary   :: !(Maybe String)
  74       , pageOtherLang :: !(Map LanguageTag PageName)
  75       , pageContent   :: !Lazy.ByteString
  76       }
  77     deriving (Show, Eq)
  78
  79
  80 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
  81 encodePageName :: PageName -> FilePath
  82 encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
  83     where
  84       fixPageName :: PageName -> PageName
  85       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
  86
  87
  88 isSafeChar :: Char -> Bool
  89 isSafeChar c
  90     | c == '/'            = True
  91     | isReserved c        = False
  92     | c > ' ' && c <= '~' = True
  93     | otherwise           = False
  94
  95
  96 -- URI unescape して UTF-8 から decode する。
  97 decodePageName :: FilePath -> PageName
  98 decodePageName = decodeString . unEscapeString
  99
 100
 101 encodeFragment :: String -> String
 102 encodeFragment = escapeURIString isSafeChar . encodeString
 103
 104
 105 pageFileName' :: Page -> String
 106 pageFileName' page
 107     = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page)
 108
 109
 110 defaultFileName :: MIMEType -> PageName -> String
 111 defaultFileName pType pName
 112     = let baseName = takeFileName pName
 113       in
 114         case pType of
 115           MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
 116           MIMEType "text" "css"     _ -> baseName <.> "css"
 117           _                           -> baseName
 118
 119
 120 mkPageURI :: URI -> PageName -> URI
 121 mkPageURI baseURI name
 122     = baseURI {
 123         uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 124       }
 125
 126
 127 mkPageFragmentURI :: URI -> PageName -> String -> URI
 128 mkPageFragmentURI baseURI name fragment
 129     = baseURI {
 130         uriPath     = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
 131       , uriFragment = ('#' : encodeFragment fragment)
 132       }
 133
 134
 135 mkFragmentURI :: String -> URI
 136 mkFragmentURI fragment
 137     = nullURI {
 138         uriFragment = ('#' : encodeFragment fragment)
 139       }
 140
 141
 142 mkObjectURI :: URI -> PageName -> URI
 143 mkObjectURI baseURI name
 144     = mkAuxiliaryURI baseURI ["object"] name
 145
 146
 147 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
 148 mkAuxiliaryURI baseURI basePath name
 149     = baseURI {
 150         uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
 151       }
 152
 153
 154 mkRakkaURI :: PageName -> URI
 155 mkRakkaURI name = URI {
 156                     uriScheme    = "rakka:"
 157                   , uriAuthority = Nothing
 158                   , uriPath      = encodePageName name
 159                   , uriQuery     = ""
 160                   , uriFragment  = ""
 161                   }
 162
 163
 164 {-
 165   <page name="Foo/Bar"
 166         type="text/x-rakka"
 167         lang="ja"            -- 存在しない場合もある
 168         fileName="bar.rakka" -- 存在しない場合もある
 169         isTheme="no"         -- text/css の場合のみ存在
 170         isFeed="no"          -- text/x-rakka の場合のみ存在
 171         isLocked="no"
 172         isBinary="no"
 173         revision="112">      -- デフォルトでない場合のみ存在
 174         lastModified="2000-01-01T00:00:00">
 175
 176     <summary>
 177         blah blah...
 178     </summary> -- 存在しない場合もある
 179
 180     <otherLang> -- 存在しない場合もある
 181       <link lang="ja" page="Bar/Baz" />
 182     </otherLang>
 183
 184     <!-- 何れか一方のみ -->
 185     <textData>
 186       blah blah...
 187     </textData>
 188     <binaryData>
 189       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
 190     </binaryData>
 191   </page>
 192 -}
 193 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 194 xmlizePage
 195     = proc page
 196     -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page
 197           ( eelem "/"
 198             += ( eelem "page"
 199                  += sattr "name" (pageName page)
 200                  += sattr "type" (show $ pageType page)
 201                  += ( case pageLanguage page of
 202                         Just x  -> sattr "lang" x
 203                         Nothing -> none
 204                     )
 205                  += ( case pageFileName page of
 206                         Just x  -> sattr "fileName" x
 207                         Nothing -> none
 208                     )
 209                  += ( case pageType page of
 210                         MIMEType "text" "css" _
 211                             -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
 212                         MIMEType "text" "x-rakka" _
 213                             -> sattr "isFeed"  (yesOrNo $ pageIsFeed page)
 214                         _
 215                             -> none
 216                     )
 217                  += sattr "isLocked" (yesOrNo $ pageIsLocked page)
 218                  += sattr "isBoring" (yesOrNo $ pageIsBoring page)
 219                  += sattr "isBinary" (yesOrNo $ pageIsBinary page)
 220                  += sattr "revision" (show $ pageRevision page)
 221                  += sattr "lastModified" (formatW3CDateTime lastMod)
 222                  += ( case pageSummary page of
 223                         Just s  -> eelem "summary" += txt s
 224                         Nothing -> none
 225                     )
 226                  += ( if M.null (pageOtherLang page) then
 227                           none
 228                       else
 229                           selem "otherLang"
 230                                     [ eelem "link"
 231                                       += sattr "lang" lang
 232                                       += sattr "page" name
 233                                           | (lang, name) <- M.toList (pageOtherLang page) ]
 234                     )
 235                  += ( if pageIsBinary page then
 236                           ( eelem "binaryData"
 237                             += txt (B64.encode $ L.unpack $ pageContent page)
 238                           )
 239                       else
 240                           ( eelem "textData"
 241                             += txt (decode $ L.unpack $ pageContent page)
 242                           )
 243                     )
 244                )) -<< ()
 245
 246
 247 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 248 parseXmlizedPage
 249     = proc (name, tree)
 250     -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 251           case redirect of
 252             Nothing   -> parseEntity -< (name, tree)
 253             Just dest -> returnA     -< (Redirection {
 254                                            redirName     = name
 255                                          , redirDest     = dest
 256                                          , redirRevision = undefined
 257                                          , redirLastMod  = undefined
 258                                          })
 259
 260
 261 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 262 parseEntity
 263     = proc (name, tree)
 264     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
 265                        >>> arr read) -< tree
 266
 267           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 268           fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
 269
 270           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 271                        >>> parseYesOrNo) -< tree
 272           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 273                        >>> parseYesOrNo) -< tree
 274           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 275                        >>> parseYesOrNo) -< tree
 276           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
 277                        >>> parseYesOrNo) -< tree
 278
 279           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 280                               >>> getText
 281                               >>> deleteIfEmpty)) -< tree
 282
 283           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 284                               >>>
 285                               (getAttrValue0 "lang"
 286                                &&&
 287                                getAttrValue0 "page")) -< tree
 288
 289           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 290           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 291
 292           let (isBinary, content)
 293                   = case (textData, binaryData) of
 294                       (Just text, Nothing    ) -> (False, L.pack $ encode text      )
 295                       (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
 296                       _                        -> error "one of textData or binaryData is required"
 297
 298           returnA -< Entity {
 299                         pageName      = name
 300                       , pageType      = mimeType
 301                       , pageLanguage  = lang
 302                       , pageFileName  = fileName
 303                       , pageIsTheme   = isTheme
 304                       , pageIsFeed    = isFeed
 305                       , pageIsLocked  = isLocked
 306                       , pageIsBoring  = isBoring
 307                       , pageIsBinary  = isBinary
 308                       , pageRevision  = undefined
 309                       , pageLastMod   = undefined
 310                       , pageSummary   = summary
 311                       , pageOtherLang = M.fromList otherLang
 312                       , pageContent   = content
 313                       }