Still in early development...

[Rakka.git] / Rakka / Storage / DefaultPage.hs

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