Implemented the outline command

[Rakka.git] / Rakka / SystemConfig.hs

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index 423e6c508d88402a9c1df0a2b264e88662bf22e6..8a6be0283914eb5e78b35fee2ec88aec5244986e 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -10,16 +10,30 @@ module Rakka.SystemConfig
     where
 
 import           Control.Arrow.ArrowIO
+import           Control.Concurrent.STM
 import           Control.Monad.Trans
 import qualified Data.ByteString.Char8 as C8
+import           Data.Encoding
+import           Data.Encoding.UTF8
+import           Data.Map (Map)
+import qualified Data.Map as M
 import           Data.Maybe
+import           GHC.Conc (unsafeIOToSTM)
 import           Network
 import qualified Network.HTTP.Lucu.Config as LC
 import           Network.URI
+import           Rakka.Utils
+import           Subversion.FileSystem
+import           Subversion.FileSystem.Revision
+import           Subversion.FileSystem.Root
+import           Subversion.Repository
+import           System.FilePath.Posix
 
 
 data SystemConfig = SystemConfig {
-      scLucuConf :: !LC.Config
+      scLucuConf   :: !LC.Config
+    , scRepository :: !Repository
+    , scCache      :: !(TVar (Map FilePath SysConfValue))
     }
 
 
@@ -28,27 +42,66 @@ data SysConfValue
     | BaseURI URI
     | DefaultPage String
     | StyleSheet String
+    deriving (Eq, Show)
 
 
-mkSystemConfig :: LC.Config -> SystemConfig
-mkSystemConfig = SystemConfig
+mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
+mkSystemConfig lc repos
+    = do cache <- newTVarIO M.empty
+         return $ SystemConfig {
+                      scLucuConf   = lc
+                    , scRepository = repos
+                    , scCache      = cache
+                    }
 
 
 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
 getSysConf sc key
-    = liftIO $ sysConfDefault sc key -- FIXME
+    = liftIO $
+      atomically $
+      do let path = sysConfPath key
+
+         cache <- readTVar (scCache sc)
+
+         case M.lookup path cache of
+           Just val -> return val
+           Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc key)
+                          writeTVar (scCache sc) (M.insert path val cache)
+                          return val
+
+
+getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
+getSysConf' sc key
+    = do fs    <- getRepositoryFS (scRepository sc)
+         rev   <- getYoungestRev fs
+         value <- withRevision fs rev
+                  $ do let path = fromConfPath (sysConfPath key)
+                       exists <- isFile path
+                       case exists of
+                         True
+                             -> do str <- getFileContentsLBS path
+                                   return $ Just $ chomp $ decodeLazy UTF8 str
+                         False
+                             -> return Nothing
+         case value of
+           Just str -> return $ unmarshalSysConf key str
+           Nothing  -> sysConfDefault sc key
 
 
 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
 getSysConfA = (arrIO0 .) . getSysConf
 
 
+fromConfPath :: FilePath -> FilePath
+fromConfPath = combine "/config"
+
+
 {- paths -}
 sysConfPath :: SysConfValue -> FilePath
-sysConfPath (SiteName    _) = "/siteName"
-sysConfPath (BaseURI     _) = "/baseURI"
-sysConfPath (DefaultPage _) = "/defaultPage"
-sysConfPath (StyleSheet  _) = "/styleSheet"
+sysConfPath (SiteName    _) = "siteName"
+sysConfPath (BaseURI     _) = "baseURI"
+sysConfPath (DefaultPage _) = "defaultPage"
+sysConfPath (StyleSheet  _) = "styleSheet"
 
 
 {- marshalling -}