improvements related to redirection

[Rakka.git] / Rakka / Page.hs

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index b293b1fb0258445edfec5261687c3996c1893e9a..2462bab30f14d44004fa4fd61e81972fa385fb96 100644 (file)
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -211,7 +211,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 +230,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 (decode $ L.unpack $ entityContent page)
+                                )
                           )
-                    )
-               )) -<< ()
+                     )) -<< ()
 
 
 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page