Rakka/SystemConfig.hs

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