, pageUpdateInfo
, pageRevision
+ , isSafeChar
, encodePageName
, decodePageName
- , entityFileName'
- , defaultFileName
-
, mkPageURI
, mkPageFragmentURI
, mkObjectURI
, mkFragmentURI
, mkAuxiliaryURI
+ , mkFeedURI
, mkRakkaURI
, xmlizePage
)
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
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as L hiding (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import Data.Char
import Data.Map (Map)
import qualified Data.Map as M
import Data.Time
import Network.HTTP.Lucu hiding (redirect)
import Network.URI hiding (fragment)
+import OpenSSL.EVP.Base64
import Rakka.Utils
import Rakka.W3CDateTime
import Subversion.Types
= Redirection {
redirName :: !PageName
, redirDest :: !PageName
+ , redirIsLocked :: !Bool
, redirRevision :: RevNum
, redirLastMod :: UTCTime
, redirUpdateInfo :: Maybe UpdateInfo
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
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
-- 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)
-- 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
mkPageURI baseURI name
= baseURI {
- uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
+ uriPath = uriPath baseURI </> encodePageName name <.> "html"
}
mkPageFragmentURI :: URI -> PageName -> String -> URI
mkPageFragmentURI baseURI name fragment
= baseURI {
- uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
+ uriPath = uriPath baseURI </> encodePageName name <.> "html"
, uriFragment = ('#' : encodeFragment fragment)
}
}
+mkFeedURI :: URI -> PageName -> URI
+mkFeedURI baseURI name
+ = baseURI {
+ uriPath = uriPath baseURI </> encodePageName name <.> "rdf"
+ }
+
+
mkRakkaURI :: PageName -> URI
mkRakkaURI name = URI {
uriScheme = "rakka:"
<page name="Foo/Bar"
type="text/x-rakka"
lang="ja" -- 存在しない場合もある
- fileName="bar.rakka" -- 存在しない場合もある
isTheme="no" -- text/css の場合のみ存在
isFeed="no" -- text/x-rakka の場合のみ存在
isLocked="no"
+= ( eelem "page"
+= sattr "name" (redirName page)
+= sattr "redirect" (redirDest page)
+ += sattr "isLocked" (yesOrNo $ redirIsLocked page)
+= sattr "revision" (show $ redirRevision page)
+= sattr "lastModified" (formatW3CDateTime lastMod)
)) -<< ()
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)
-> 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)
)
+= ( if entityIsBinary page then
( eelem "binaryData"
- += txt (B64.encode $ L.unpack $ entityContent page)
+ += txt (L8.unpack $ encodeBase64LBS $ entityContent page)
)
else
( eelem "textData"
- += txt (decode $ L.unpack $ entityContent page)
+ += txt (UTF8.decode $ L.unpack $ entityContent page)
)
)
)) -<< ()
= 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
= 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
>>> 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
let (isBinary, content)
= case (textData, binaryData) of
- (Just text, Nothing ) -> (False, L.pack $ encode text )
- (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
+ (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text)
+ (Nothing , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace 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
- , entityIsBoring = isBoring
, entityIsBinary = isBinary
, entityRevision = undefined
, entityLastMod = undefined
, 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
projects / Rakka.git / blobdiff