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