Implemented the outline command

[Rakka.git] / Rakka / SystemConfig.hs

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index ea7e370cfe7aa8d31edb9b643d1e0d40ae01e59f..8a6be0283914eb5e78b35fee2ec88aec5244986e 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -10,57 +10,114 @@ 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))
     }
 
 
 data SysConfValue
     = SiteName String
     | 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 (StyleSheet _) = "/styleSheet"
+sysConfPath (SiteName    _) = "siteName"
+sysConfPath (BaseURI     _) = "baseURI"
+sysConfPath (DefaultPage _) = "defaultPage"
+sysConfPath (StyleSheet  _) = "styleSheet"
 
 
 {- marshalling -}
 marshalSysConf :: SysConfValue -> String
-marshalSysConf (SiteName   name) = name
-marshalSysConf (BaseURI    uri ) = uriToString id uri ""
-marshalSysConf (StyleSheet name) = name
+marshalSysConf (SiteName    name) = name
+marshalSysConf (BaseURI     uri ) = uriToString id uri ""
+marshalSysConf (DefaultPage name) = name
+marshalSysConf (StyleSheet  name) = name
 
 
 {- unmarshalling -}
 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
-unmarshalSysConf (SiteName   _) name = SiteName name
-unmarshalSysConf (BaseURI    _) uri  = BaseURI $ fromJust $ parseURI uri
-unmarshalSysConf (StyleSheet _) name = StyleSheet name
+unmarshalSysConf (SiteName    _) name = SiteName name
+unmarshalSysConf (BaseURI     _) uri  = BaseURI $ fromJust $ parseURI uri
+unmarshalSysConf (DefaultPage _) name = DefaultPage name
+unmarshalSysConf (StyleSheet  _) name = StyleSheet name
 
 
 {- getting default value -}
@@ -83,5 +140,8 @@ sysConfDefault sc (BaseURI _)
 
          return $ BaseURI $ fromJust $ parseURI defaultURI
 
+sysConfDefault _ (DefaultPage _)
+    = return $ DefaultPage "MainPage"
+
 sysConfDefault _ (StyleSheet _)
     = return $ StyleSheet "StyleSheet/Default"