From 35f9c2ec3c1e81e42737c54f3f1a8230427691c6 Mon Sep 17 00:00:00 2001 From: pho Date: Mon, 8 Oct 2007 14:43:02 +0900 Subject: [PATCH] wrote Loader.DefaultPage but not tested yet darcs-hash:20071008054302-62b54-0b71726a7063b7026f71a2af8958250ebd1193b7.gz --- .boring | 3 +- Rakka.cabal | 12 +++- Rakka/Page.hs | 40 ++++++++++++ Rakka/Page/Loader/DefaultPage.hs | 101 +++++++++++++++++++++++++++++++ Rakka/Utils.hs | 40 ++++++++++++ defaultPages/Main_Page | 4 +- schemas/rakka-page-1.0.rng | 96 ++++++++++++++++++++++++++--- 7 files changed, 283 insertions(+), 13 deletions(-) create mode 100644 Rakka/Page.hs create mode 100644 Rakka/Page/Loader/DefaultPage.hs create mode 100644 Rakka/Utils.hs diff --git a/.boring b/.boring index eac5262..d545fc2 100644 --- a/.boring +++ b/.boring @@ -48,7 +48,8 @@ \.(obj|a|exe|so|lo|la)$ ^\.darcs-temp-mail$ -.setup-config$ +^\.installed-pkg-config$ +^\.setup-config$ ^Rakka.buildinfo$ ^Setup$ ^configure$ diff --git a/Rakka.cabal b/Rakka.cabal index a1c8a71..56bb669 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -20,8 +20,16 @@ Category: 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 @@ -30,3 +38,5 @@ Executable: rakka Main-Is: Main.hs +GHC-Options: + -fwarn-unused-imports \ No newline at end of file diff --git a/Rakka/Page.hs b/Rakka/Page.hs new file mode 100644 index 0000000..5647c8e --- /dev/null +++ b/Rakka/Page.hs @@ -0,0 +1,40 @@ +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 diff --git a/Rakka/Page/Loader/DefaultPage.hs b/Rakka/Page/Loader/DefaultPage.hs new file mode 100644 index 0000000..2133217 --- /dev/null +++ b/Rakka/Page/Loader/DefaultPage.hs @@ -0,0 +1,101 @@ +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 diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs new file mode 100644 index 0000000..cb77474 --- /dev/null +++ b/Rakka/Utils.hs @@ -0,0 +1,40 @@ +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 diff --git a/defaultPages/Main_Page b/defaultPages/Main_Page index 1c0a421..1acd8ae 100644 --- a/defaultPages/Main_Page +++ b/defaultPages/Main_Page @@ -1,6 +1,8 @@ + type="text/x-rakka" + isBoring="yes"> + This is the main page. Hello, world! diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng index b85385b..42b1733 100644 --- a/schemas/rakka-page-1.0.rng +++ b/schemas/rakka-page-1.0.rng @@ -4,17 +4,93 @@ datatypeLibrary="http://www.w3.org/2001/XMLSchema-datatypes" xmlns="http://relaxng.org/ns/structure/1.0"> - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - + + + + + + -- 2.40.0