Rakka/SystemConfig.hs

   1 module Rakka.SystemConfig
   2     ( SystemConfig
   3     , SysConfValue(..)
   4
   5     , mkSystemConfig -- private
   6
   7     , getSysConf
   8     , getSysConfA
   9     )
  10     where
  11
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Concurrent.STM
  14 import           Control.Monad.Trans
  15 import qualified Data.ByteString.Char8 as C8
  16 import           Data.Encoding
  17 import           Data.Encoding.UTF8
  18 import           Data.Map (Map)
  19 import qualified Data.Map as M
  20 import           Data.Maybe
  21 import           GHC.Conc (unsafeIOToSTM)
  22 import           Network
  23 import qualified Network.HTTP.Lucu.Config as LC
  24 import           Network.HTTP.Lucu.Utils
  25 import           Network.URI
  26 import           Rakka.Page
  27 import           Rakka.Utils
  28 import           Subversion.FileSystem
  29 import           Subversion.FileSystem.Revision
  30 import           Subversion.FileSystem.Root
  31 import           Subversion.Repository
  32 import           System.FilePath.Posix
  33 import           System.Log.Logger
  34
  35 logger = "Rakka.SystemConfig"
  36
  37
  38 data SystemConfig = SystemConfig {
  39       scLucuConf   :: !LC.Config
  40     , scRepository :: !Repository
  41     , scCache      :: !(TVar (Map FilePath SysConfValue))
  42     }
  43
  44
  45 data SysConfValue
  46     = SiteName String
  47     | BaseURI URI
  48     | DefaultPage String
  49     | StyleSheet String
  50     | Languages (Map LanguageTag LanguageName)
  51     deriving (Eq, Show)
  52
  53
  54 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
  55 mkSystemConfig lc repos
  56     = do cache <- newTVarIO M.empty
  57          return $ SystemConfig {
  58                       scLucuConf   = lc
  59                     , scRepository = repos
  60                     , scCache      = cache
  61                     }
  62
  63
  64 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
  65 getSysConf sc key
  66     = liftIO $
  67       atomically $
  68       do let path = sysConfPath key
  69
  70          cache <- readTVar (scCache sc)
  71
  72          case M.lookup path cache of
  73            Just val -> return val
  74            Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc key)
  75                           writeTVar (scCache sc) (M.insert path val cache)
  76                           return val
  77
  78
  79 getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
  80 getSysConf' sc key
  81     = do let path = fromConfPath (sysConfPath key)
  82
  83          fs    <- getRepositoryFS (scRepository sc)
  84          rev   <- getYoungestRev fs
  85          value <- withRevision fs rev
  86                   $ do exists <- isFile path
  87                        case exists of
  88                          True
  89                              -> do str <- getFileContentsLBS path
  90                                    return $ Just $ chomp $ decodeLazy UTF8 str
  91                          False
  92                              -> return Nothing
  93
  94          case value of
  95            Just str
  96                -> do let val = unmarshalSysConf key str
  97                      debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
  98                      return val
  99            Nothing
 100                -> do val <- sysConfDefault sc key
 101                      debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
 102                      return val
 103
 104
 105 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
 106 getSysConfA = (arrIO0 .) . getSysConf
 107
 108
 109 fromConfPath :: FilePath -> FilePath
 110 fromConfPath = combine "/config"
 111
 112
 113 marshalStringPairs :: [(String, String)] -> String
 114 marshalStringPairs = joinWith "\n" . map marshalPair'
 115     where
 116       marshalPair' :: (String, String) -> String
 117       marshalPair' (a, b) = a ++ " " ++ b
 118
 119
 120 unmarshalStringPairs :: String -> [(String, String)]
 121 unmarshalStringPairs = catMaybes . map unmarshalPair' . lines
 122     where
 123       unmarshalPair' :: String -> Maybe (String, String)
 124       unmarshalPair' s = case break (/= ' ') s of
 125                            (a, ' ':b) -> Just (a, b)
 126                            _          -> Nothing
 127
 128
 129 {- paths -}
 130 sysConfPath :: SysConfValue -> FilePath
 131 sysConfPath (SiteName    _) = "siteName"
 132 sysConfPath (BaseURI     _) = "baseURI"
 133 sysConfPath (DefaultPage _) = "defaultPage"
 134 sysConfPath (StyleSheet  _) = "styleSheet"
 135 sysConfPath (Languages   _) = "languages"
 136
 137
 138 {- marshalling -}
 139 marshalSysConf :: SysConfValue -> String
 140 marshalSysConf (SiteName    name ) = name
 141 marshalSysConf (BaseURI     uri  ) = uriToString id uri ""
 142 marshalSysConf (DefaultPage name ) = name
 143 marshalSysConf (StyleSheet  name ) = name
 144 marshalSysConf (Languages   langs) = marshalStringPairs (M.toList langs)
 145
 146
 147 {- unmarshalling -}
 148 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
 149 unmarshalSysConf (SiteName    _) name  = SiteName name
 150 unmarshalSysConf (BaseURI     _) uri   = BaseURI $ fromJust $ parseURI uri
 151 unmarshalSysConf (DefaultPage _) name  = DefaultPage name
 152 unmarshalSysConf (StyleSheet  _) name  = StyleSheet name
 153 unmarshalSysConf (Languages   _) langs = Languages $ M.fromList $ unmarshalStringPairs langs
 154
 155
 156 {- getting default value -}
 157 sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
 158
 159 sysConfDefault _ (SiteName _)
 160     = return $ SiteName "Rakka"
 161
 162 sysConfDefault sc (BaseURI _)
 163     = do let conf = scLucuConf sc
 164              host = C8.unpack $ LC.cnfServerHost conf
 165              port = case LC.cnfServerPort conf of
 166                       PortNumber num -> fromIntegral num
 167
 168              defaultURI
 169                   = "http://" ++ host ++
 170                     (if port == 80
 171                      then ""
 172                      else ':' : show port) ++ "/"
 173
 174          return $ BaseURI $ fromJust $ parseURI defaultURI
 175
 176 sysConfDefault _ (DefaultPage _)
 177     = return $ DefaultPage "MainPage"
 178
 179 sysConfDefault _ (StyleSheet _)
 180     = return $ StyleSheet "StyleSheet/Default"
 181
 182 sysConfDefault _ (Languages _)
 183     = return
 184       $ Languages
 185       $ M.fromList [ ("en", "English"  )
 186                    , ("es", "Español"  )
 187                    , ("de", "Deutsch"  )
 188                    , ("fi", "Suomi"    )
 189                    , ("fr", "Français" )
 190                    , ("ga", "Gaeilge"  )
 191                    , ("gd", "Gàidhlig" )
 192                    , ("ja", "日本語"  )
 193                    , ("pt", "Português")
 194                    , ("sv", "Svenska"  )
 195                    ]
 196