X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FPage.hs;h=62606b35af111daa344d37d738dfabd4aa273172;hb=23977989ef4be7316b1c2c3f709ca1e8e6bb7f84;hp=f701d92078e757a0ada421d7d54f33e8d4d2b609;hpb=d128bc12ae9f763c37941122bf2e163517810bba;p=Rakka.git

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index f701d92..62606b3 100644
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -15,9 +15,6 @@ module Rakka.Page
     , encodePageName
     , decodePageName
 
-    , entityFileName'
-    , defaultFileName
-
     , mkPageURI
     , mkPageFragmentURI
     , mkObjectURI
@@ -63,6 +60,7 @@ data Page
     = Redirection {
         redirName       :: !PageName
       , redirDest       :: !PageName
+      , redirIsLocked   :: !Bool
       , redirRevision   :: RevNum
       , redirLastMod    :: UTCTime
       , redirUpdateInfo :: Maybe UpdateInfo
@@ -71,11 +69,9 @@ data Page
         entityName       :: !PageName
       , entityType       :: !MIMEType
       , entityLanguage   :: !(Maybe LanguageTag)
-      , entityFileName   :: !(Maybe String)
       , entityIsTheme    :: !Bool     -- text/css 以外では無意味
       , entityIsFeed     :: !Bool     -- text/x-rakka 以外では無意味
       , entityIsLocked   :: !Bool
-      , entityIsBoring   :: !Bool
       , entityIsBinary   :: !Bool
       , entityRevision   :: RevNum
       , entityLastMod    :: UTCTime
@@ -96,13 +92,13 @@ data UpdateInfo
 
 
 isRedirect :: Page -> Bool
-isRedirect (Redirection _ _ _ _ _) = True
-isRedirect _                       = False
+isRedirect (Redirection _ _ _ _ _ _) = True
+isRedirect _                         = False
 
 
 isEntity :: Page -> Bool
-isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True
-isEntity _                                      = False
+isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _) = True
+isEntity _                                  = False
 
 
 pageName :: Page -> PageName
@@ -151,21 +147,6 @@ encodeFragment :: String -> String
 encodeFragment = escapeURIString isSafeChar . UTF8.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
-
-
 mkPageURI :: URI -> PageName -> URI
 mkPageURI baseURI name
     = baseURI {
@@ -214,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"
@@ -260,6 +240,7 @@ xmlizePage
                   += ( eelem "page"
                        += sattr "name"     (redirName page)
                        += sattr "redirect" (redirDest page)
+                       += sattr "isLocked" (yesOrNo $ redirIsLocked page)
                        += sattr "revision" (show $ redirRevision page)
                        += sattr "lastModified" (formatW3CDateTime lastMod)
                      )) -<< ()
@@ -276,10 +257,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)
@@ -289,7 +266,6 @@ xmlizePage
                                   -> 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)
@@ -323,11 +299,14 @@ parseXmlizedPage
     = proc (name, tree)
     -> do updateInfo <- maybeA parseUpdateInfo -< tree
           redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
+          isLocked   <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
+                         >>> parseYesOrNo) -< tree
           case redirect of
             Nothing   -> parseEntity -< (name, tree)
             Just dest -> returnA     -< (Redirection {
                                            redirName       = name
                                          , redirDest       = dest
+                                         , redirIsLocked   = isLocked
                                          , redirRevision   = undefined
                                          , redirLastMod    = undefined
                                          , redirUpdateInfo = updateInfo
@@ -342,7 +321,6 @@ parseEntity
           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
@@ -350,8 +328,6 @@ parseEntity
                        >>> parseYesOrNo) -< tree
           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
-          isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
-                       >>> parseYesOrNo) -< tree
 
           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
                               >>> getText
@@ -369,7 +345,7 @@ parseEntity
           let (isBinary, content)
                   = case (textData, binaryData) of
                       (Just text, Nothing    ) -> (False, L.pack $ UTF8.encode text )
-                      (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
+                      (Nothing  , Just binary) -> (True , L.pack $ fromJust $ B64.decode $ dropWhitespace binary)
                       _                        -> error "one of textData or binaryData is required"
               mimeType
                   =  if isBinary then
@@ -384,11 +360,9 @@ parseEntity
                         entityName       = name
                       , entityType       = mimeType
                       , entityLanguage   = lang
-                      , entityFileName   = fileName
                       , entityIsTheme    = isTheme
                       , entityIsFeed     = isFeed
                       , entityIsLocked   = isLocked
-                      , entityIsBoring   = isBoring
                       , entityIsBinary   = isBinary
                       , entityRevision   = undefined
                       , entityLastMod    = undefined
@@ -397,14 +371,22 @@ parseEntity
                       , entityContent    = content
                       , entityUpdateInfo = updateInfo
                       }
+    where
+      dropWhitespace :: String -> String
+      dropWhitespace [] = []
+      dropWhitespace (x:xs)
+          | x == ' ' || x == '\t' || x == '\n'
+              = dropWhitespace xs
+          | otherwise
+              = x : dropWhitespace xs
 
 
 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 parseUpdateInfo 
     = proc tree
-    -> do uInfo   <- getXPathTreesInDoc "/*/updateInfo" -< tree
+    -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
-          oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo
+          oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
           returnA -< UpdateInfo {
                         uiOldRevision = oldRev
                       , uiOldName     = oldName