\.(obj|a|exe|so|lo|la)$
^\.darcs-temp-mail$
-.setup-config$
+^\.installed-pkg-config$
+^\.setup-config$
^Rakka.buildinfo$
^Setup$
^configure$
Web
Tested-With:
GHC == 6.6.1
+Extensions:
+ Arrows
+GHC-Options:
+ -fwarn-unused-imports
Build-Depends:
- base, network, unix, Lucu
+ base, network, unix, encoding, base64-string, hxt, Lucu
+Exposed-Modules:
+ Rakka.Page
+Other-Modules:
+ Rakka.Page.Loader.DefaultPage
Data-Files:
defaultPages/Main_Page
schemas/rakka-page-1.0.rng
rakka
Main-Is:
Main.hs
+GHC-Options:
+ -fwarn-unused-imports
\ No newline at end of file
--- /dev/null
+module Rakka.Page
+ ( PageName
+ , Page(..)
+ , encodePageName
+ )
+ where
+
+import Data.ByteString.Base (LazyByteString)
+import qualified Data.ByteString.Char8 as C8
+import Data.Encoding
+import Data.Encoding.UTF8
+import Network.HTTP.Lucu
+import Network.URI
+
+
+type PageName = String
+
+
+data Page
+ = Redirect PageName
+ | Page {
+ pageType :: MIMEType
+ , pageIsTheme :: Bool -- text/css 以外では無意味
+ , pageIsFeed :: Bool -- text/x-rakka 以外では無意味
+ , pageIsLocked :: Bool
+ , pageIsBoring :: Bool
+ , pageSummary :: Maybe String
+ , pageOtherLang :: [(String, PageName)]
+ , pageContent :: LazyByteString
+ }
+
+
+-- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
+encodePageName :: PageName -> FilePath
+encodePageName = escapeURIString shouldEscape . C8.unpack . encode UTF8
+ where
+ shouldEscape :: Char -> Bool
+ shouldEscape c
+ | c >= ' ' && c <= '~' = False
+ | otherwise = True
--- /dev/null
+module Rakka.Page.Loader.DefaultPage
+ ( loadDefaultPage
+ )
+ where
+
+import qualified Codec.Binary.Base64.String as B64
+import Control.Arrow
+import Control.Arrow.ArrowList
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Paths_Rakka -- Cabal が用意する。
+import Rakka.Page
+import Rakka.Utils
+import System.Directory
+import Text.XML.HXT.Arrow.ReadDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.Arrow.XmlNodeSet
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+loadDefaultPage :: PageName -> IO (Maybe Page)
+loadDefaultPage pageName
+ -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
+ = do let pagePath = encodePageName pageName
+ isInDataDir <- doesFileExist ("./data/" ++ pagePath)
+ if isInDataDir then
+ return . Just =<< loadPageFile ("./data/" ++ pagePath)
+ else
+ do fpath <- getDataFileName ("defaultPages/" ++ pagePath)
+ isInstalled <- doesFileExist fpath
+ if isInstalled then
+ return . Just =<< loadPageFile fpath
+ else
+ return Nothing
+
+
+loadPageFile :: FilePath -> IO Page
+loadPageFile path
+ = do [page] <- runX ( constA path
+ >>>
+ loadPageFileA
+ )
+ return page
+
+
+loadPageFileA :: IOStateArrow s FilePath Page
+loadPageFileA = ( readFromDocument [ (a_validate , v_0)
+ , (a_check_namespaces , v_1)
+ , (a_remove_whitespace, v_1)
+ ]
+ >>>
+ parsePage
+ )
+
+
+parsePage :: (ArrowXml a, ArrowChoice a) => a XmlTree Page
+parsePage
+ = proc tree -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
+ >>> arr read) -< tree
+
+ isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
+ >>> defaultTo "no"
+ >>> parseYesOrNo) -< tree
+ isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
+ >>> defaultTo "no"
+ >>> parseYesOrNo) -< tree
+ isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
+ >>> defaultTo "no"
+ >>> parseYesOrNo) -< tree
+ isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
+ >>> defaultTo "no"
+ >>> parseYesOrNo) -< tree
+
+ summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
+ >>> getText
+ >>> deleteIfEmpty)) -< tree
+
+ otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
+ >>>
+ (getAttrValue0 "lang"
+ &&&
+ getAttrValue0 "page")) -< tree
+
+ textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree
+ binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
+
+ let content = case (textData, binaryData) of
+ (Just text, _ ) -> L8.pack text
+ (_ , Just binary) -> L8.pack $ B64.decode binary
+
+ returnA -< Page {
+ pageType = mimeType
+ , pageIsTheme = isTheme
+ , pageIsFeed = isFeed
+ , pageIsLocked = isLocked
+ , pageIsBoring = isBoring
+ , pageSummary = summary
+ , pageOtherLang = otherLang
+ , pageContent = content
+ }
\ No newline at end of file
--- /dev/null
+module Rakka.Utils
+ ( parseYesOrNo
+ , maybeA
+ , defaultTo
+ , deleteIfEmpty
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+
+
+parseYesOrNo :: ArrowChoice a => a String Bool
+parseYesOrNo
+ = proc str -> do case str of
+ "yes" -> returnA -< True
+ "no" -> returnA -< False
+ _ -> returnA -< error ("Expected yes or no: " ++ str)
+
+
+maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
+maybeA a = listA a
+ >>>
+ proc xs -> case xs of
+ [] -> returnA -< Nothing
+ (x:_) -> returnA -< Just x
+
+
+defaultTo :: ArrowChoice a => b -> a (Maybe b) b
+defaultTo def
+ = proc m -> case m of
+ Nothing -> returnA -< def
+ Just x -> returnA -< x
+
+
+deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
+deleteIfEmpty
+ = proc str -> do case str of
+ "" -> none -< ()
+ _ -> returnA -< str
\ No newline at end of file
<?xml version="1.0" encoding="UTF-8"?>
<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
- type="text/x-rakka">
+ type="text/x-rakka"
+ isBoring="yes">
+
<textData>
This is the main page. Hello, world!
</textData>
datatypeLibrary="http://www.w3.org/2001/XMLSchema-datatypes"
xmlns="http://relaxng.org/ns/structure/1.0">
- <attribute name="type">
- <text />
- </attribute>
-
<choice>
- <element name="textData">
- <text />
- </element>
+ <!-- リダイレクトの場合 -->
+ <attribute name="redirect">
+ <!-- ページ名 -->
+ <data type="anyURI" />
+ </attribute>
+
+ <!-- リダイレクトでない場合 -->
+ <group>
+ <attribute name="type">
+ <!-- MIME Type -->
+ <text />
+ </attribute>
+
+ <optional>
+ <!-- text/css でなければ無視される -->
+ <attribute name="isTheme">
+ <!-- これは HXT が對應してゐない。
+ <data type="string">
+ <param name="pattern">yes|no</param>
+ </data>
+ -->
+ <text />
+ </attribute>
+ </optional>
+
+ <optional>
+ <!-- text/x-rakka でなければ無視される -->
+ <attribute name="isFeed">
+ <!-- yes/no -->
+ <text />
+ </attribute>
+ </optional>
+
+ <optional>
+ <!-- ログインしてゐないユーザーの編集を禁止するフラグ -->
+ <attribute name="isLocked">
+ <!-- yes/no -->
+ <text />
+ </attribute>
+ </optional>
+
+ <optional>
+ <!-- 更新履歴や RSS から削除されるフラグ -->
+ <attribute name="isBoring">
+ <!-- yes/no -->
+ <text />
+ </attribute>
+ </optional>
+
+ <interleave>
+ <optional>
+ <element name="summary">
+ <text />
+ </element>
+ </optional>
+
+ <optional>
+ <element name="otherLang">
+ <zeroOrMore>
+ <element name="link">
+ <attribute name="lang">
+ <!-- RFC 4646 言語コード -->
+ <text />
+ </attribute>
+ <attribute name="page">
+ <!-- ページ名 -->
+ <data type="anyURI" />
+ </attribute>
+ </element>
+ </zeroOrMore>
+ </element>
+ </optional>
+ </interleave>
+
+ <choice>
+ <element name="textData">
+ <text />
+ </element>
- <element name="binaryData">
- <text />
- </element>
+ <element name="binaryData">
+ <!-- これは HXT が對應してゐない。
+ <data type="base64Binary" />
+ -->
+ <text />
+ </element>
+ </choice>
+ </group>
</choice>
</element>
projects / Rakka.git / commitdiff