25 import qualified Codec.Binary.Base64 as B64
26 import Codec.Binary.UTF8.String
28 import Control.Arrow.ArrowIO
29 import Control.Arrow.ArrowList
30 import qualified Data.ByteString.Lazy as Lazy (ByteString)
31 import qualified Data.ByteString.Lazy as L hiding (ByteString)
34 import qualified Data.Map as M
37 import Network.HTTP.Lucu hiding (redirect)
38 import Network.URI hiding (fragment)
40 import Rakka.W3CDateTime
41 import Subversion.Types
42 import System.FilePath.Posix
43 import Text.XML.HXT.Arrow.XmlArrow
44 import Text.XML.HXT.Arrow.XmlNodeSet
45 import Text.XML.HXT.DOM.TypeDefs
48 type PageName = String
50 type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
51 type LanguageName = String -- i.e. "日本語"
56 redirName :: !PageName
57 , redirDest :: !PageName
58 , redirRevision :: RevNum
59 , redirLastMod :: UTCTime
63 , pageType :: !MIMEType
64 , pageLanguage :: !(Maybe LanguageTag)
65 , pageFileName :: !(Maybe String)
66 , pageIsTheme :: !Bool -- text/css 以外では無意味
67 , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味
68 , pageIsLocked :: !Bool
69 , pageIsBoring :: !Bool
70 , pageIsBinary :: !Bool
71 , pageRevision :: RevNum
72 , pageLastMod :: UTCTime
73 , pageSummary :: !(Maybe String)
74 , pageOtherLang :: !(Map LanguageTag PageName)
75 , pageContent :: !Lazy.ByteString
80 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
81 encodePageName :: PageName -> FilePath
82 encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
84 fixPageName :: PageName -> PageName
85 fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
88 isSafeChar :: Char -> Bool
91 | isReserved c = False
92 | c > ' ' && c <= '~' = True
96 -- URI unescape して UTF-8 から decode する。
97 decodePageName :: FilePath -> PageName
98 decodePageName = decodeString . unEscapeString
101 encodeFragment :: String -> String
102 encodeFragment = escapeURIString isSafeChar . encodeString
105 pageFileName' :: Page -> String
107 = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page)
110 defaultFileName :: MIMEType -> PageName -> String
111 defaultFileName pType pName
112 = let baseName = takeFileName pName
115 MIMEType "text" "x-rakka" _ -> baseName <.> "rakka"
116 MIMEType "text" "css" _ -> baseName <.> "css"
120 mkPageURI :: URI -> PageName -> URI
121 mkPageURI baseURI name
123 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
127 mkPageFragmentURI :: URI -> PageName -> String -> URI
128 mkPageFragmentURI baseURI name fragment
130 uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
131 , uriFragment = ('#' : encodeFragment fragment)
135 mkFragmentURI :: String -> URI
136 mkFragmentURI fragment
138 uriFragment = ('#' : encodeFragment fragment)
142 mkObjectURI :: URI -> PageName -> URI
143 mkObjectURI baseURI name
144 = mkAuxiliaryURI baseURI ["object"] name
147 mkAuxiliaryURI :: URI -> [String] -> PageName -> URI
148 mkAuxiliaryURI baseURI basePath name
150 uriPath = foldl (</>) "/" ([uriPath baseURI] ++ basePath ++ [encodePageName name])
154 mkRakkaURI :: PageName -> URI
155 mkRakkaURI name = URI {
157 , uriAuthority = Nothing
158 , uriPath = encodePageName name
167 lang="ja" -- 存在しない場合もある
168 fileName="bar.rakka" -- 存在しない場合もある
169 isTheme="no" -- text/css の場合のみ存在
170 isFeed="no" -- text/x-rakka の場合のみ存在
173 revision="112"> -- デフォルトでない場合のみ存在
174 lastModified="2000-01-01T00:00:00">
178 </summary> -- 存在しない場合もある
180 <otherLang> -- 存在しない場合もある
181 <link lang="ja" page="Bar/Baz" />
189 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
193 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
196 -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page
199 += sattr "name" (pageName page)
200 += sattr "type" (show $ pageType page)
201 += ( case pageLanguage page of
202 Just x -> sattr "lang" x
205 += ( case pageFileName page of
206 Just x -> sattr "fileName" x
209 += ( case pageType page of
210 MIMEType "text" "css" _
211 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
212 MIMEType "text" "x-rakka" _
213 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
217 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
218 += sattr "isBoring" (yesOrNo $ pageIsBoring page)
219 += sattr "isBinary" (yesOrNo $ pageIsBinary page)
220 += sattr "revision" (show $ pageRevision page)
221 += sattr "lastModified" (formatW3CDateTime lastMod)
222 += ( case pageSummary page of
223 Just s -> eelem "summary" += txt s
226 += ( if M.null (pageOtherLang page) then
233 | (lang, name) <- M.toList (pageOtherLang page) ]
235 += ( if pageIsBinary page then
237 += txt (B64.encode $ L.unpack $ pageContent page)
241 += txt (decode $ L.unpack $ pageContent page)
247 parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
250 -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
252 Nothing -> parseEntity -< (name, tree)
253 Just dest -> returnA -< (Redirection {
256 , redirRevision = undefined
257 , redirLastMod = undefined
261 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
264 -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
265 >>> arr read) -< tree
267 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
268 fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
270 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
271 >>> parseYesOrNo) -< tree
272 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
273 >>> parseYesOrNo) -< tree
274 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
275 >>> parseYesOrNo) -< tree
276 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
277 >>> parseYesOrNo) -< tree
279 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
281 >>> deleteIfEmpty)) -< tree
283 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
285 (getAttrValue0 "lang"
287 getAttrValue0 "page")) -< tree
289 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
290 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
292 let (isBinary, content)
293 = case (textData, binaryData) of
294 (Just text, Nothing ) -> (False, L.pack $ encode text )
295 (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
296 _ -> error "one of textData or binaryData is required"
300 , pageType = mimeType
301 , pageLanguage = lang
302 , pageFileName = fileName
303 , pageIsTheme = isTheme
304 , pageIsFeed = isFeed
305 , pageIsLocked = isLocked
306 , pageIsBoring = isBoring
307 , pageIsBinary = isBinary
308 , pageRevision = undefined
309 , pageLastMod = undefined
310 , pageSummary = summary
311 , pageOtherLang = M.fromList otherLang
312 , pageContent = content