+{-# LANGUAGE
+ Arrows
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Page
( PageName
, Page(..)
, mkObjectURI
, mkFragmentURI
, mkAuxiliaryURI
+ , mkFeedURI
, mkRakkaURI
, xmlizePage
, parseXmlizedPage
)
where
-
-import qualified Codec.Binary.Base64 as B64
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode
import qualified Codec.Binary.UTF8.String as UTF8
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowList
+import qualified Data.ByteString.Char8 as B8
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.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.Map (Map)
import qualified Data.Map as M
-import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
import Network.URI hiding (fragment)
+import OpenSSL.EVP.Base64
+import Prelude.Unicode
import Rakka.Utils
-import Rakka.W3CDateTime
import Subversion.Types
import System.FilePath.Posix
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
-import Text.XML.HXT.DOM.TypeDefs
-
-
-type PageName = String
-
-type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
-type LanguageName = String -- i.e. "日本語"
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
+type PageName = Text
+type LanguageTag = CI Text -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
+type LanguageName = Text -- i.e. "日本語"
data Page
= Redirection {
redirName :: !PageName
, redirDest :: !PageName
+ , redirIsLocked :: !Bool
, redirRevision :: RevNum
, redirLastMod :: UTCTime
, redirUpdateInfo :: Maybe UpdateInfo
, entityIsTheme :: !Bool -- text/css 以外では無意味
, entityIsFeed :: !Bool -- text/x-rakka 以外では無意味
, entityIsLocked :: !Bool
- , entityIsBoring :: !Bool
, entityIsBinary :: !Bool
, entityRevision :: RevNum
, entityLastMod :: UTCTime
}
deriving (Show, Eq)
-
data UpdateInfo
= UpdateInfo {
uiOldRevision :: !RevNum
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 . UTF8.encodeString . fixPageName
+encodePageName ∷ PageName → FilePath
+encodePageName = escapeURIString isSafeChar ∘ UTF8.encodeString ∘ fixPageName ∘ T.unpack
where
- fixPageName :: PageName -> PageName
- fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
-
+ fixPageName ∷ String → String
+ fixPageName = capitalizeHead ∘ map (\c → if c ≡ ' ' then '_' else c)
-isSafeChar :: Char -> Bool
-isSafeChar c
- | c == '/' = True
- | isReserved c = False
- | c > ' ' && c <= '~' = True
- | otherwise = False
+ capitalizeHead ∷ String → String
+ capitalizeHead [] = (⊥)
+ capitalizeHead (x:xs) = toUpper x : xs
+-- FIXME: use system-filepath
+decodePageName ∷ FilePath → PageName
+decodePageName = T.pack ∘ UTF8.decodeString ∘ unEscapeString
--- URI unescape して UTF-8 から decode する。
-decodePageName :: FilePath -> PageName
-decodePageName = UTF8.decodeString . unEscapeString
+encodeFragment ∷ Text → String
+encodeFragment = escapeURIString isSafeChar ∘ B8.unpack ∘ encodeUtf8
-
-encodeFragment :: String -> String
-encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
-
-
-mkPageURI :: URI -> PageName -> URI
+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 ∷ URI → PageName → Text → URI
mkPageFragmentURI baseURI name fragment
= baseURI {
- uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".html"]
+ uriPath = uriPath baseURI </> encodePageName name <.> "html"
, uriFragment = ('#' : encodeFragment fragment)
}
-
-mkFragmentURI :: String -> URI
+mkFragmentURI ∷ Text → URI
mkFragmentURI fragment
= nullURI {
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:"
-> 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)
+ += sattr "name" (T.unpack $ redirName page )
+ += sattr "redirect" (T.unpack $ redirDest page )
+ += sattr "isLocked" (yesOrNo $ redirIsLocked page)
+ += sattr "revision" (show $ redirRevision page)
+ += sattr "lastModified" (W3C.format lastMod)
)) -<< ()
xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
-> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
( eelem "/"
+= ( eelem "page"
- += sattr "name" (pageName page)
+ += sattr "name" (T.unpack $ pageName page)
+= sattr "type" (show $ entityType page)
+= ( case entityLanguage page of
- Just x -> sattr "lang" x
+ Just x -> sattr "lang" (T.unpack $ CI.foldedCase x)
Nothing -> none
)
+= ( case entityType page of
-> 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)
+ += sattr "lastModified" (W3C.format lastMod)
+= ( case entitySummary page of
Just s -> eelem "summary" += txt s
Nothing -> none
else
selem "otherLang"
[ eelem "link"
- += sattr "lang" lang
- += sattr "page" name
- | (lang, name) <- M.toList (entityOtherLang page) ]
+ += sattr "lang" (T.unpack $ CI.foldedCase lang)
+ += sattr "page" (T.unpack name)
+ | (lang, name) ← M.toList (entityOtherLang page) ]
)
+= ( if entityIsBinary page then
( eelem "binaryData"
- += txt (B64.encode $ L.unpack $ entityContent page)
+ += txt (L8.unpack $ encodeBase64LBS $ entityContent page)
)
else
( eelem "textData"
)
)) -<< ()
-
-parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
+parseXmlizedPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (PageName, XmlTree) ⇝ Page
parseXmlizedPage
= proc (name, tree)
- -> do updateInfo <- maybeA parseUpdateInfo -< tree
- redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
- case redirect of
- Nothing -> parseEntity -< (name, tree)
- Just dest -> returnA -< (Redirection {
- redirName = name
- , redirDest = dest
- , redirRevision = undefined
- , redirLastMod = undefined
- , redirUpdateInfo = updateInfo
- })
-
+ → 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 = T.pack dest
+ , redirIsLocked = isLocked
+ , redirRevision = undefined
+ , redirLastMod = undefined
+ , redirUpdateInfo = updateInfo
+ }
parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
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
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)
+ (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 {
+ = if isBinary then
+ if null mimeTypeStr then
+ guessMIMEType content
+ else
+ read mimeTypeStr
+ else
+ read mimeTypeStr
+ returnA ⤙ Entity {
entityName = name
, entityType = mimeType
- , entityLanguage = lang
+ , entityLanguage = CI.mk ∘ T.pack <$> lang
, entityIsTheme = isTheme
, entityIsFeed = isFeed
, entityIsLocked = isLocked
- , entityIsBoring = isBoring
, entityIsBinary = isBinary
, entityRevision = undefined
, entityLastMod = undefined
, entitySummary = summary
- , entityOtherLang = M.fromList otherLang
+ , entityOtherLang = M.fromList ((CI.mk ∘ T.pack ⁂ T.pack) <$> otherLang)
, entityContent = content
, entityUpdateInfo = updateInfo
}
-
-parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
+parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo
parseUpdateInfo
= proc tree
- -> do uInfo <- getXPathTreesInDoc "/page/updateInfo" -< tree
- oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
- oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
- returnA -< UpdateInfo {
- uiOldRevision = oldRev
- , uiOldName = oldName
- }
-
-
\ No newline at end of file
+ -> do uInfo ← getXPathTreesInDoc "/page/updateInfo" ⤙ tree
+ oldRev ← (getAttrValue0 "oldRevision" ⋙ arr read) ⤙ uInfo
+ oldName ← maybeA (getXPathTrees "/updateInfo/move/@from/text()" ⋙ getText) ⤙ uInfo
+ returnA ⤙ UpdateInfo {
+ uiOldRevision = oldRev
+ , uiOldName = T.pack <$> oldName
+ }
+
+dropWhitespace :: String -> String
+{-# INLINE dropWhitespace #-}
+dropWhitespace = filter ((¬) ∘ isSpace)
projects / Rakka.git / blobdiff