Still in early development...

darcs-hash:20071008063434-62b54-36037e999275efbd6253ead38b9ebff033576ca3.gz

diff --git a/Rakka.cabal b/Rakka.cabal
index 56bb66983ed56241c84e2971fd1b569ad9588ab3..14087de06a07cb6ba4a4f63d2b54ce17025b537d 100644 (file)
--- 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 069f9eba3ceb34e8ea2d57c4ccf7551b3c155874..e793d0001f401b7e07a1c0b4fd9c38bc10787a4b 100644 (file)
--- 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 5647c8e1481d61df62cf49828164e302cbdb3923..607a0a81b9035b76104b4d87fd677eb190da0266 100644 (file)
--- 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 (file)
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 (file)
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 (file)
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