, getSysConf
, getSysConfA
+
+ , SiteName(..)
+ , BaseURI(..)
+ , DefaultPage(..)
+ , StyleSheet(..)
+ , Languages(..)
)
where
import Control.Concurrent.STM
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
+import Data.Dynamic
import Data.Encoding
import Data.Encoding.UTF8
import Data.Map (Map)
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
- | Languages (Map LanguageTag LanguageName)
- 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
, 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 let path = fromConfPath (sysConfPath key)
+getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
+getSysConf' sc
+ = do let path = fromConfPath $ confPath (undefined :: a)
fs <- getRepositoryFS (scRepository sc)
rev <- getYoungestRev fs
case value of
Just str
- -> do let val = unmarshalSysConf key str
- debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
- return val
+ -> 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 val <- sysConfDefault sc key
+ -> 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"
-marshalStringPairs :: [(String, String)] -> String
-marshalStringPairs = joinWith "\n" . map marshalPair'
+serializeStringPairs :: [(String, String)] -> String
+serializeStringPairs = joinWith "\n" . map serializePair'
where
- marshalPair' :: (String, String) -> String
- marshalPair' (a, b) = a ++ " " ++ b
+ serializePair' :: (String, String) -> String
+ serializePair' (a, b) = a ++ " " ++ b
-unmarshalStringPairs :: String -> [(String, String)]
-unmarshalStringPairs = catMaybes . map unmarshalPair' . lines
+deserializeStringPairs :: String -> Maybe [(String, String)]
+deserializeStringPairs = sequence . map deserializePair' . lines
where
- unmarshalPair' :: String -> Maybe (String, String)
- unmarshalPair' s = case break (/= ' ') s of
- (a, ' ':b) -> Just (a, b)
- _ -> Nothing
-
-
-{- paths -}
-sysConfPath :: SysConfValue -> FilePath
-sysConfPath (SiteName _) = "siteName"
-sysConfPath (BaseURI _) = "baseURI"
-sysConfPath (DefaultPage _) = "defaultPage"
-sysConfPath (StyleSheet _) = "styleSheet"
-sysConfPath (Languages _) = "languages"
-
-
-{- marshalling -}
-marshalSysConf :: SysConfValue -> String
-marshalSysConf (SiteName name ) = name
-marshalSysConf (BaseURI uri ) = uriToString id uri ""
-marshalSysConf (DefaultPage name ) = name
-marshalSysConf (StyleSheet name ) = name
-marshalSysConf (Languages langs) = marshalStringPairs (M.toList langs)
-
-
-{- 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
-unmarshalSysConf (Languages _) langs = Languages $ M.fromList $ unmarshalStringPairs langs
-
-
-{- getting default value -}
-sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
-
-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
+ 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 (parseURI uri)
+ defaultValue sc
+ = let conf = scLucuConf sc
+ host = C8.unpack $ LC.cnfServerHost conf
+ port = case LC.cnfServerPort conf of
+ PortNumber num -> fromIntegral num
+
+ defaultURI
= "http://" ++ host ++
(if port == 80
then ""
else ':' : show port) ++ "/"
-
- return $ BaseURI $ fromJust $ parseURI defaultURI
-
-sysConfDefault _ (DefaultPage _)
- = return $ DefaultPage "MainPage"
-
-sysConfDefault _ (StyleSheet _)
- = return $ StyleSheet "StyleSheet/Default"
-
-sysConfDefault _ (Languages _)
- = return
- $ 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" )
- ]
-
+ 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" )
+ ]
projects / Rakka.git / blobdiff