X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;h=ecf608df873232944880dbc0b518d6644cbebf46;hb=f1016753ef45a4c25745ccb6e81e5acbc085cc42;hp=8a6be0283914eb5e78b35fee2ec88aec5244986e;hpb=3c5211253dc61c31196a47486c538b64c32d8c5e;p=Rakka.git

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index 8a6be02..ecf608d 100644
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -6,43 +6,61 @@ module Rakka.SystemConfig
 
     , getSysConf
     , getSysConfA
+
+    , SiteName(..)
+    , BaseURI(..)
+    , DefaultPage(..)
+    , StyleSheet(..)
+    , Languages(..)
+    , GlobalLock(..)
+
+    , serializeStringPairs
+    , deserializeStringPairs
     )
     where
 
+import           Codec.Binary.UTF8.String
 import           Control.Arrow.ArrowIO
 import           Control.Concurrent.STM
+import           Control.Monad
 import           Control.Monad.Trans
 import qualified Data.ByteString.Char8 as C8
-import           Data.Encoding
-import           Data.Encoding.UTF8
+import qualified Data.ByteString.Lazy  as L
+import           Data.Dynamic
 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           Network.HTTP.Lucu.Utils
+import           Network.URI hiding (path)
+import           Rakka.Page
 import           Rakka.Utils
 import           Subversion.FileSystem
 import           Subversion.FileSystem.Revision
 import           Subversion.FileSystem.Root
 import           Subversion.Repository
 import           System.FilePath.Posix
+import           System.Log.Logger
+
+
+logger :: String
+logger = "Rakka.SystemConfig"
 
 
 data SystemConfig = SystemConfig {
       scLucuConf   :: !LC.Config
     , scRepository :: !Repository
-    , scCache      :: !(TVar (Map FilePath SysConfValue))
+    , scCache      :: !(TVar (Map FilePath Dynamic))
     }
 
 
-data SysConfValue
-    = SiteName String
-    | BaseURI URI
-    | DefaultPage String
-    | StyleSheet String
-    deriving (Eq, Show)
+class (Typeable a, Show a) => SysConfValue a where
+    confPath     :: a -> FilePath
+    serialize    :: a -> String
+    deserialize  :: String -> Maybe a
+    defaultValue :: SystemConfig -> a
 
 
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
@@ -54,94 +72,153 @@ mkSystemConfig lc repos
                     , scCache      = cache
                     }
 
-
-getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
-getSysConf sc key
+getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
+getSysConf sc
     = liftIO $
       atomically $
-      do let path = sysConfPath key
+      do let path = confPath (undefined :: a)
 
          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)
+           Just val -> return $ fromJust $ fromDynamic val
+           Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc)
+                          writeTVar (scCache sc) (M.insert path (toDyn val) cache)
                           return val
 
 
-getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
-getSysConf' sc key
-    = do fs    <- getRepositoryFS (scRepository sc)
+getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
+getSysConf' sc
+    = do let path = fromConfPath $ confPath (undefined :: a)
+
+         fs    <- getRepositoryFS (scRepository sc)
          rev   <- getYoungestRev fs
          value <- withRevision fs rev
-                  $ do let path = fromConfPath (sysConfPath key)
-                       exists <- isFile path
+                  $ do exists <- isFile path
                        case exists of
                          True
                              -> do str <- getFileContentsLBS path
-                                   return $ Just $ chomp $ decodeLazy UTF8 str
+                                   return $ Just $ chomp $ decode $ L.unpack str
                          False
                              -> return Nothing
+
          case value of
-           Just str -> return $ unmarshalSysConf key str
-           Nothing  -> sysConfDefault sc key
+           Just str
+               -> case deserialize str of
+                    Just val
+                        -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
+                              return val
+                    Nothing
+                        -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
+           Nothing
+               -> do let val = defaultValue sc
+                     debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
+                     return val
 
 
-getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
-getSysConfA = (arrIO0 .) . getSysConf
+getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
+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"
+fromConfPath = ("/config" </>)
 
 
-{- marshalling -}
-marshalSysConf :: SysConfValue -> String
-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 (DefaultPage _) name = DefaultPage name
-unmarshalSysConf (StyleSheet  _) name = StyleSheet name
-
-
-{- getting default value -}
-sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
+serializeStringPairs :: [(String, String)] -> String
+serializeStringPairs = joinWith "\n" . map serializePair'
+    where
+      serializePair' :: (String, String) -> String
+      serializePair' (a, b) = a ++ " " ++ b
 
-sysConfDefault _ (SiteName _)
-    = return $ SiteName "Rakka"
 
-sysConfDefault sc (BaseURI _)
-    = do let conf = scLucuConf sc
-             host = C8.unpack $ LC.cnfServerHost conf
-             port = case LC.cnfServerPort conf of
-                      PortNumber num -> fromIntegral num
-             
-             defaultURI
-                  = "http://" ++ host ++
+deserializeStringPairs :: String -> Maybe [(String, String)]
+deserializeStringPairs = sequence . map deserializePair' . lines
+    where
+      deserializePair' :: String -> Maybe (String, String)
+      deserializePair' s = case break (== ' ') s of
+                             (a, ' ':b) -> Just (a, b)
+                             _          -> Nothing
+
+
+
+{- config values -}
+
+newtype SiteName = SiteName String deriving (Show, Typeable)
+instance SysConfValue SiteName where
+    confPath _                = "siteName"
+    serialize (SiteName name) = name
+    deserialize name          = Just (SiteName name)
+    defaultValue _            = SiteName "Rakka"
+
+
+newtype BaseURI = BaseURI URI deriving (Show, Typeable)
+instance SysConfValue BaseURI where
+    confPath _              = "baseURI"
+    serialize (BaseURI uri) = uriToString id uri ""
+    deserialize uri         = fmap BaseURI
+                              $ do parsed <- parseURI uri
+                                   when (uriPath parsed        == "" ) (fail undefined)
+                                   when (last (uriPath parsed) /= '/') (fail undefined)
+                                   when (uriQuery parsed       /= "" ) (fail undefined)
+                                   when (uriFragment parsed    /= "" ) (fail undefined)
+                                   return parsed
+    defaultValue sc
+        = let conf = scLucuConf sc
+              host = C8.unpack $ LC.cnfServerHost conf
+              port = case LC.cnfServerPort conf of
+                       PortNumber num -> fromIntegral num :: Int
+                       _              -> undefined
+              defaultURI
+                  = "http://" ++ host ++ -- FIXME: consider IPv6 address
                     (if port == 80
                      then ""
                      else ':' : show port) ++ "/"
-
-         return $ BaseURI $ fromJust $ parseURI defaultURI
-
-sysConfDefault _ (DefaultPage _)
-    = return $ DefaultPage "MainPage"
-
-sysConfDefault _ (StyleSheet _)
-    = return $ StyleSheet "StyleSheet/Default"
+          in
+            BaseURI $ fromJust $ parseURI defaultURI
+
+
+newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
+instance SysConfValue DefaultPage where
+    confPath _                   = "defaultPage"
+    serialize (DefaultPage name) = name
+    deserialize name             = Just (DefaultPage name)
+    defaultValue _               = DefaultPage "MainPage"
+
+
+newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
+instance SysConfValue StyleSheet where
+    confPath _                  = "styleSheet"
+    serialize (StyleSheet name) = name
+    deserialize name            = Just (StyleSheet name)
+    defaultValue _              = StyleSheet "StyleSheet/Default"
+
+
+newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
+instance SysConfValue Languages where
+    confPath _                  = "languages"
+    serialize (Languages langs) = serializeStringPairs (M.toList langs)
+    deserialize langs           = fmap (Languages . M.fromList) (deserializeStringPairs langs)
+    defaultValue _         
+        = Languages $ M.fromList [ ("en", "English"  )
+                                 , ("es", "Español"  )
+                                 , ("de", "Deutsch"  )
+                                 , ("fi", "Suomi"    )
+                                 , ("fr", "Français" )
+                                 , ("ga", "Gaeilge"  )
+                                 , ("gd", "Gàidhlig" )
+                                 , ("ja", "日本語"  )
+                                 , ("pt", "Português")
+                                 , ("sv", "Svenska"  )
+                                 ]
+
+
+newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable)
+instance SysConfValue GlobalLock where
+    confPath _      = "globalLock"
+    serialize (GlobalLock isLocked)
+        | isLocked  = "*"
+        | otherwise = ""
+    deserialize "*" = Just (GlobalLock True)
+    deserialize ""  = Just (GlobalLock False)
+    deserialize _   = Nothing
+    defaultValue _  = GlobalLock False