X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=f701d92078e757a0ada421d7d54f33e8d4d2b609;hb=d128bc12ae9f763c37941122bf2e163517810bba;hp=b293b1fb0258445edfec5261687c3996c1893e9a;hpb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;p=Rakka.git

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index b293b1f..f701d92 100644
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -10,6 +10,7 @@ module Rakka.Page
 
     , pageName
     , pageUpdateInfo
+    , pageRevision
 
     , encodePageName
     , decodePageName
@@ -30,7 +31,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
@@ -108,19 +109,26 @@ 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,11 +144,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
+encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
 
 
 entityFileName' :: Page -> String
@@ -211,7 +219,7 @@ mkRakkaURI name = URI {
         isFeed="no"          -- text/x-rakka の場合のみ存在
         isLocked="no"
         isBinary="no"
-        revision="112">      -- デフォルトでない場合のみ存在
+        revision="112"
         lastModified="2000-01-01T00:00:00">
 
     <summary>
@@ -230,59 +238,84 @@ mkRakkaURI name = URI {
       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
     </binaryData>
   </page>
+
+  <page name="Foo/Bar"
+        redirect="Baz"
+        revision="112"
+        lastModified="2000-01-01T00:00:00" />
 -}
 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
 xmlizePage 
     = proc page
-    -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
-          ( eelem "/"
-            += ( eelem "page"
-                 += sattr "name" (pageName page)
-                 += sattr "type" (show $ entityType page)
-                 += ( case entityLanguage page of
-                        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)
-                        MIMEType "text" "x-rakka" _
-                            -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
-                        _
-                            -> none
-                    )
-                 += sattr "isLocked" (yesOrNo $ entityIsLocked page)
-                 += sattr "isBoring" (yesOrNo $ entityIsBoring page)
-                 += sattr "isBinary" (yesOrNo $ entityIsBinary page)
-                 += sattr "revision" (show $ entityRevision page)
-                 += sattr "lastModified" (formatW3CDateTime lastMod)
-                 += ( case entitySummary page of
-                        Just s  -> eelem "summary" += txt s
-                        Nothing -> none
-                    )
-                 += ( if M.null (entityOtherLang page) then
-                          none
-                      else
-                          selem "otherLang"
-                                    [ eelem "link"
-                                      += sattr "lang" lang
-                                      += sattr "page" name
-                                          | (lang, name) <- M.toList (entityOtherLang page) ]
-                    )
-                 += ( if entityIsBinary page then
-                          ( eelem "binaryData"
-                            += txt (B64.encode $ L.unpack $ entityContent page)
+    -> if isRedirect page then
+           xmlizeRedirection -< page
+       else
+           xmlizeEntity -< page
+    where
+      xmlizeRedirection :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
+      xmlizeRedirection 
+          = proc page
+          -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
+                ( eelem "/"
+                  += ( eelem "page"
+                       += sattr "name"     (redirName page)
+                       += sattr "redirect" (redirDest page)
+                       += sattr "revision" (show $ redirRevision page)
+                       += sattr "lastModified" (formatW3CDateTime lastMod)
+                     )) -<< ()
+
+      xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
+      xmlizeEntity 
+          = proc page
+          -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
+                ( eelem "/"
+                  += ( eelem "page"
+                       += sattr "name" (pageName page)
+                       += sattr "type" (show $ entityType page)
+                       += ( case entityLanguage page of
+                              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)
+                              MIMEType "text" "x-rakka" _
+                                  -> sattr "isFeed"  (yesOrNo $ entityIsFeed page)
+                              _
+                                  -> none
+                          )
+                       += sattr "isLocked" (yesOrNo $ entityIsLocked page)
+                       += sattr "isBoring" (yesOrNo $ entityIsBoring page)
+                       += sattr "isBinary" (yesOrNo $ entityIsBinary page)
+                       += sattr "revision" (show $ entityRevision page)
+                       += sattr "lastModified" (formatW3CDateTime lastMod)
+                       += ( case entitySummary page of
+                              Just s  -> eelem "summary" += txt s
+                              Nothing -> none
+                          )
+                       += ( if M.null (entityOtherLang page) then
+                                none
+                            else
+                                selem "otherLang"
+                                          [ eelem "link"
+                                            += sattr "lang" lang
+                                            += sattr "page" name
+                                                | (lang, name) <- M.toList (entityOtherLang page) ]
                           )
-                      else
-                          ( eelem "textData"
-                            += txt (decode $ L.unpack $ entityContent page)
+                       += ( if entityIsBinary page then
+                                ( eelem "binaryData"
+                                  += txt (B64.encode $ L.unpack $ entityContent page)
+                                )
+                            else
+                                ( eelem "textData"
+                                  += txt (UTF8.decode $ L.unpack $ entityContent page)
+                                )
                           )
-                    )
-               )) -<< ()
+                     )) -<< ()
 
 
 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
@@ -306,8 +339,7 @@ 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
@@ -336,9 +368,17 @@ 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