From: pho Date: Mon, 8 Oct 2007 06:34:34 +0000 (+0900) Subject: Still in early development... X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=484e15845d9c06d0fa62044d3b6b3ff8c78a6e04;p=Rakka.git Still in early development... darcs-hash:20071008063434-62b54-36037e999275efbd6253ead38b9ebff033576ca3.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index 56bb669..14087de 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -25,11 +25,14 @@ Extensions: GHC-Options: -fwarn-unused-imports Build-Depends: - base, network, unix, encoding, base64-string, hxt, Lucu + base, network, unix, encoding, base64-string, hxt, HsSVN, Lucu Exposed-Modules: Rakka.Page + Rakka.Storage Other-Modules: - Rakka.Page.Loader.DefaultPage + Rakka.Environment + Rakka.Storage.DefaultPage + Rakka.Utils Data-Files: defaultPages/Main_Page schemas/rakka-page-1.0.rng @@ -38,5 +41,7 @@ Executable: rakka Main-Is: Main.hs +Extensions: + Arrows GHC-Options: -fwarn-unused-imports \ No newline at end of file diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 069f9eb..e793d00 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -6,11 +6,13 @@ module Rakka.Environment import Network import qualified Network.HTTP.Lucu.Config as LC +import Rakka.Storage data Environment = Environment { envLocalStateDir :: FilePath , envLucuConf :: LC.Config + , envStorage :: Storage } @@ -19,7 +21,9 @@ setupEnv lsdir portNum = do let lucuConf = LC.defaultConfig { LC.cnfServerPort = PortNumber portNum } + storage <- mkStorage -- FIXME return $ Environment { envLocalStateDir = lsdir , envLucuConf = lucuConf + , envStorage = storage } \ No newline at end of file diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 5647c8e..607a0a8 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -11,6 +11,7 @@ import Data.Encoding import Data.Encoding.UTF8 import Network.HTTP.Lucu import Network.URI +import Subversion.Types type PageName = String @@ -19,11 +20,13 @@ type PageName = String data Page = Redirect PageName | Page { - pageType :: MIMEType + pageName :: PageName + , pageType :: MIMEType , pageIsTheme :: Bool -- text/css 以外では無意味 , pageIsFeed :: Bool -- text/x-rakka 以外では無意味 , pageIsLocked :: Bool , pageIsBoring :: Bool + , pageRevision :: Maybe RevNum , pageSummary :: Maybe String , pageOtherLang :: [(String, PageName)] , pageContent :: LazyByteString diff --git a/Rakka/Page/Loader/DefaultPage.hs b/Rakka/Page/Loader/DefaultPage.hs deleted file mode 100644 index 2133217..0000000 --- a/Rakka/Page/Loader/DefaultPage.hs +++ /dev/null @@ -1,101 +0,0 @@ -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/Storage.hs b/Rakka/Storage.hs new file mode 100644 index 0000000..d830131 --- /dev/null +++ b/Rakka/Storage.hs @@ -0,0 +1,29 @@ +module Rakka.Storage + ( Storage + + , mkStorage -- private + + , getPage + , savePage + ) + where + +import Rakka.Page +import Rakka.Storage.DefaultPage + + +data Storage = Storage -- FIXME + + +mkStorage :: IO Storage -- FIXME +mkStorage = return Storage + + +getPage :: Storage -> PageName -> IO (Maybe Page) +getPage sto name + = loadDefaultPage name -- FIXME + + +savePage :: Storage -> PageName -> Page -> IO () +savePage sto name page + = error "FIXME: not implemented" diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs new file mode 100644 index 0000000..8770ef0 --- /dev/null +++ b/Rakka/Storage/DefaultPage.hs @@ -0,0 +1,104 @@ +module Rakka.Storage.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 pageName ("./data/" ++ pagePath) + else + do fpath <- getDataFileName ("defaultPages/" ++ pagePath) + isInstalled <- doesFileExist fpath + if isInstalled then + return . Just =<< loadPageFile pageName fpath + else + return Nothing + + +loadPageFile :: PageName -> FilePath -> IO Page +loadPageFile name path + = do [page] <- runX ( constA (name, path) + >>> + loadPageFileA + ) + return page + + +loadPageFileA :: IOStateArrow s (PageName, FilePath) Page +loadPageFileA + = proc (name, fpath) -> + do tree <- readFromDocument [ (a_validate , v_0) + , (a_check_namespaces , v_1) + , (a_remove_whitespace, v_1) + ] -< fpath + parsePage -< (name, tree) + + +parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page +parsePage + = proc (name, 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 { + pageName = name + , pageType = mimeType + , pageIsTheme = isTheme + , pageIsFeed = isFeed + , pageIsLocked = isLocked + , pageIsBoring = isBoring + , pageRevision = Nothing + , pageSummary = summary + , pageOtherLang = otherLang + , pageContent = content + } \ No newline at end of file