X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=9883b576f9be232abb5a715735c5c9109c004d6a;hb=bf15724655b75bf1b8f0fdabb111c158a91680a8;hp=2462bab30f14d44004fa4fd61e81972fa385fb96;hpb=701592b0fae35ebc8cb4f855c7701c88fc75566b;p=Rakka.git

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 2462bab..9883b57 100644
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -10,13 +10,11 @@ module Rakka.Page
 
     , pageName
     , pageUpdateInfo
+    , pageRevision
 
     , encodePageName
     , decodePageName
 
-    , entityFileName'
-    , defaultFileName
-
     , mkPageURI
     , mkPageFragmentURI
     , mkObjectURI
@@ -30,7 +28,7 @@ module Rakka.Page
     where
 
 import qualified Codec.Binary.Base64 as B64
-import           Codec.Binary.UTF8.String
+import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
@@ -70,7 +68,6 @@ data Page
         entityName       :: !PageName
       , entityType       :: !MIMEType
       , entityLanguage   :: !(Maybe LanguageTag)
-      , entityFileName   :: !(Maybe String)
       , entityIsTheme    :: !Bool     -- text/css 以外では無意味
       , entityIsFeed     :: !Bool     -- text/x-rakka 以外では無意味
       , entityIsLocked   :: !Bool
@@ -100,27 +97,34 @@ isRedirect _                       = False
 
 
 isEntity :: Page -> Bool
-isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
-isEntity _                                      = False
+isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
+isEntity _                                    = False
 
 
 pageName :: Page -> PageName
 pageName p
     | isRedirect p = redirName p
     | isEntity   p = entityName p
-    | otherwise    = fail "neither redirection nor entity"
+    | otherwise    = error "neither redirection nor entity"
 
 
 pageUpdateInfo :: Page -> Maybe UpdateInfo
 pageUpdateInfo p
     | isRedirect p = redirUpdateInfo p
     | isEntity   p = entityUpdateInfo p
-    | otherwise    = fail "neither redirection nor entity"
+    | otherwise    = error "neither redirection nor entity"
+
+
+pageRevision :: Page -> RevNum
+pageRevision p
+    | isRedirect p = redirRevision p
+    | isEntity   p = entityRevision p
+    | otherwise    = error "neither redirection nor entity"
 
 
 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 encodePageName :: PageName -> FilePath
-encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
+encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
     where
       fixPageName :: PageName -> PageName
       fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
@@ -136,26 +140,11 @@ isSafeChar c
 
 -- URI unescape して UTF-8 から decode する。
 decodePageName :: FilePath -> PageName
-decodePageName = decodeString . unEscapeString
+decodePageName = UTF8.decodeString . unEscapeString
 
 
 encodeFragment :: String -> String
-encodeFragment = escapeURIString isSafeChar . encodeString
-
-
-entityFileName' :: Page -> String
-entityFileName' page
-    = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page)
-
-
-defaultFileName :: MIMEType -> PageName -> String
-defaultFileName pType pName
-    = let baseName = takeFileName pName
-      in 
-        case pType of
-          MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
-          MIMEType "text" "css"     _ -> baseName <.> "css"
-          _                           -> baseName
+encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 
 
 mkPageURI :: URI -> PageName -> URI
@@ -206,7 +195,6 @@ mkRakkaURI name = URI {
   <page name="Foo/Bar"
         type="text/x-rakka"
         lang="ja"            -- 存在しない場合もある
-        fileName="bar.rakka" -- 存在しない場合もある
         isTheme="no"         -- text/css の場合のみ存在
         isFeed="no"          -- text/x-rakka の場合のみ存在
         isLocked="no"
@@ -268,10 +256,6 @@ xmlizePage
                               Just x  -> sattr "lang" x
                               Nothing -> none
                           )
-                       += ( case entityFileName page of
-                              Just x  -> sattr "fileName" x
-                              Nothing -> none
-                          )
                        += ( case entityType page of
                               MIMEType "text" "css" _
                                   -> sattr "isTheme" (yesOrNo $ entityIsTheme page)
@@ -304,7 +288,7 @@ xmlizePage
                                 )
                             else
                                 ( eelem "textData"
-                                  += txt (decode $ L.unpack $ entityContent page)
+                                  += txt (UTF8.decode $ L.unpack $ entityContent page)
                                 )
                           )
                      )) -<< ()
@@ -331,11 +315,9 @@ parseEntity
     = proc (name, tree)
     -> do updateInfo <- maybeA parseUpdateInfo -< tree
 
-          mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
-                       >>> arr read) -< tree
+          mimeTypeStr <- withDefault (getXPathTreesInDoc "/page/@type/text()" >>> getText) "" -< tree
 
           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
-          fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
 
           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
@@ -361,15 +343,22 @@ parseEntity
 
           let (isBinary, content)
                   = case (textData, binaryData) of
-                      (Just text, Nothing    ) -> (False, L.pack $ encode text      )
+                      (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text )
                       (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
                       _                        -> error "one of textData or binaryData is required"
+              mimeType
+                  =  if isBinary then
+                         if null mimeTypeStr then
+                             guessMIMEType content
+                         else
+                             read mimeTypeStr
+                     else
+                         read mimeTypeStr
 
           returnA -< Entity {
                         entityName       = name
                       , entityType       = mimeType
                       , entityLanguage   = lang
-                      , entityFileName   = fileName
                       , entityIsTheme    = isTheme
                       , entityIsFeed     = isFeed
                       , entityIsLocked   = isLocked