Rakka/SystemConfig.hs

   1 module Rakka.SystemConfig
   2     ( SystemConfig
   3     , SysConfValue(..)
   4
   5     , mkSystemConfig -- private
   6
   7     , getSysConf
   8     , getSysConfA
   9
  10     , setSysConf
  11     , setSysConfA
  12
  13     , SiteName(..)
  14     , BaseURI(..)
  15     , DefaultPage(..)
  16     , StyleSheet(..)
  17     , Languages(..)
  18     , GlobalLock(..)
  19
  20     , serializeStringPairs
  21     , deserializeStringPairs
  22     )
  23     where
  24
  25 import           Codec.Binary.UTF8.String
  26 import           Control.Arrow.ArrowIO
  27 import           Control.Concurrent.STM
  28 import           Control.Monad
  29 import           Control.Monad.Trans
  30 import qualified Data.ByteString.Char8 as C8
  31 import qualified Data.ByteString.Lazy  as L
  32 import           Data.Dynamic
  33 import           Data.Map (Map)
  34 import qualified Data.Map as M
  35 import           Data.Maybe
  36 import           GHC.Conc (unsafeIOToSTM)
  37 import           Network
  38 import qualified Network.HTTP.Lucu.Config as LC
  39 import           Network.HTTP.Lucu.Utils
  40 import           Network.HTTP.Lucu hiding (Config)
  41 import           Network.URI hiding (path)
  42 import           Rakka.Page
  43 import           Rakka.Utils
  44 import           Subversion.FileSystem
  45 import           Subversion.FileSystem.Revision
  46 import           Subversion.FileSystem.Root
  47 import           Subversion.FileSystem.Transaction
  48 import           Subversion.Repository
  49 import           Subversion.Types
  50 import           System.FilePath.Posix
  51 import           System.Log.Logger
  52
  53
  54 logger :: String
  55 logger = "Rakka.SystemConfig"
  56
  57
  58 data SystemConfig = SystemConfig {
  59       scLucuConf   :: !LC.Config
  60     , scRepository :: !Repository
  61     , scCache      :: !(TVar (Map FilePath Dynamic))
  62     }
  63
  64
  65 class (Typeable a, Show a, Eq a) => SysConfValue a where
  66     confPath     :: a -> FilePath
  67     serialize    :: a -> String
  68     deserialize  :: String -> Maybe a
  69     defaultValue :: SystemConfig -> a
  70
  71
  72 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
  73 mkSystemConfig lc repos
  74     = do cache <- newTVarIO M.empty
  75          return $ SystemConfig {
  76                       scLucuConf   = lc
  77                     , scRepository = repos
  78                     , scCache      = cache
  79                     }
  80
  81 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
  82 getSysConf sc
  83     = liftIO $
  84       atomically $
  85       do let path = confPath (undefined :: a)
  86
  87          cache <- readTVar (scCache sc)
  88
  89          case M.lookup path cache of
  90            Just val -> return $ fromJust $ fromDynamic val
  91            Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc)
  92                           writeTVar (scCache sc) (M.insert path (toDyn val) cache)
  93                           return val
  94
  95
  96 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
  97 getSysConf' sc
  98     = do let path = fromConfPath $ confPath (undefined :: a)
  99
 100          fs    <- getRepositoryFS (scRepository sc)
 101          rev   <- getYoungestRev fs
 102          value <- withRevision fs rev
 103                   $ do exists <- isFile path
 104                        case exists of
 105                          True
 106                              -> do str <- getFileContentsLBS path
 107                                    return $ Just $ chomp $ decode $ L.unpack str
 108                          False
 109                              -> return Nothing
 110
 111          case value of
 112            Just str
 113                -> case deserialize str of
 114                     Just val
 115                         -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
 116                               return val
 117                     Nothing
 118                         -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
 119            Nothing
 120                -> do let val = defaultValue sc
 121                      debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
 122                      return val
 123
 124
 125 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
 126 setSysConf sc userID value
 127     = liftIO $
 128       do let path = confPath (undefined :: a)
 129
 130          current <- getSysConf sc
 131          if current == value
 132             then return NotModified
 133             else do atomically $ do cache <- readTVar (scCache sc)
 134                                     writeTVar (scCache sc) (M.delete path cache)
 135                     setSysConf' sc userID value
 136
 137
 138 setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode
 139 setSysConf' sc userID value
 140     = do let path  = fromConfPath $ confPath (undefined :: a)
 141              str   = L.pack $ encode $ serialize value ++ "\n"
 142              repos = scRepository sc
 143          fs  <- getRepositoryFS repos
 144          rev <- getYoungestRev fs
 145          ret <- doReposTxn
 146                 repos
 147                 rev
 148                 userID
 149                 (Just "Automatic commit by Rakka for systemConfig update")
 150                 $ do exists <- isFile path
 151                      unless exists
 152                          $ createValueEntry path
 153                      applyTextLBS path Nothing str
 154          case ret of
 155                   Left  _ -> return Conflict
 156                   Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value)
 157                                 return Created
 158     where
 159     createValueEntry :: FilePath -> Txn ()
 160     createValueEntry path
 161         = do createParentDirectories path
 162              makeFile path
 163
 164     createParentDirectories :: FilePath -> Txn ()
 165     createParentDirectories path
 166         = do let parentPath = takeDirectory path
 167              kind <- checkPath parentPath
 168              case kind of
 169                        NoNode   -> do createParentDirectories parentPath
 170                                       makeDirectory parentPath
 171                        FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 172                        DirNode  -> return ()
 173
 174
 175 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 176 getSysConfA = arrIO0 . getSysConf
 177
 178
 179 setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
 180 setSysConfA = (arrIO .) . setSysConf
 181
 182
 183 fromConfPath :: FilePath -> FilePath
 184 fromConfPath = ("/config" </>)
 185
 186
 187 serializeStringPairs :: [(String, String)] -> String
 188 serializeStringPairs = joinWith "\n" . map serializePair'
 189     where
 190       serializePair' :: (String, String) -> String
 191       serializePair' (a, b) = a ++ " " ++ b
 192
 193
 194 deserializeStringPairs :: String -> Maybe [(String, String)]
 195 deserializeStringPairs = sequence . map deserializePair' . lines
 196     where
 197       deserializePair' :: String -> Maybe (String, String)
 198       deserializePair' s = case break (== ' ') s of
 199                              (a, ' ':b) -> Just (a, b)
 200                              _          -> Nothing
 201
 202
 203
 204 {- config values -}
 205
 206 newtype SiteName = SiteName String deriving (Show, Typeable, Eq)
 207 instance SysConfValue SiteName where
 208     confPath _                = "siteName"
 209     serialize (SiteName name) = name
 210     deserialize name          = Just (SiteName name)
 211     defaultValue _            = SiteName "Rakka"
 212
 213
 214 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
 215 instance SysConfValue BaseURI where
 216     confPath _              = "baseURI"
 217     serialize (BaseURI uri) = uriToString id uri ""
 218     deserialize uri         = fmap BaseURI
 219                               $ do parsed <- parseURI uri
 220                                    when (uriPath parsed        == "" ) (fail undefined)
 221                                    when (last (uriPath parsed) /= '/') (fail undefined)
 222                                    when (uriQuery parsed       /= "" ) (fail undefined)
 223                                    when (uriFragment parsed    /= "" ) (fail undefined)
 224                                    return parsed
 225     defaultValue sc
 226         = let conf = scLucuConf sc
 227               host = C8.unpack $ LC.cnfServerHost conf
 228               port = case LC.cnfServerPort conf of
 229                        PortNumber num -> fromIntegral num :: Int
 230                        _              -> undefined
 231               defaultURI
 232                   = "http://" ++ host ++ -- FIXME: consider IPv6 address
 233                     (if port == 80
 234                      then ""
 235                      else ':' : show port) ++ "/"
 236           in
 237             BaseURI $ fromJust $ parseURI defaultURI
 238
 239
 240 newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)
 241 instance SysConfValue DefaultPage where
 242     confPath _                   = "defaultPage"
 243     serialize (DefaultPage name) = name
 244     deserialize name             = Just (DefaultPage name)
 245     defaultValue _               = DefaultPage "MainPage"
 246
 247
 248 newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)
 249 instance SysConfValue StyleSheet where
 250     confPath _                  = "styleSheet"
 251     serialize (StyleSheet name) = name
 252     deserialize name            = Just (StyleSheet name)
 253     defaultValue _              = StyleSheet "StyleSheet/Default"
 254
 255
 256 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
 257 instance SysConfValue Languages where
 258     confPath _                  = "languages"
 259     serialize (Languages langs) = serializeStringPairs (M.toList langs)
 260     deserialize langs           = fmap (Languages . M.fromList) (deserializeStringPairs langs)
 261     defaultValue _
 262         = Languages $ M.fromList [ ("en", "English"  )
 263                                  , ("es", "Español"  )
 264                                  , ("de", "Deutsch"  )
 265                                  , ("fi", "Suomi"    )
 266                                  , ("fr", "Français" )
 267                                  , ("ga", "Gaeilge"  )
 268                                  , ("gd", "Gàidhlig" )
 269                                  , ("ja", "日本語"  )
 270                                  , ("pt", "Português")
 271                                  , ("sv", "Svenska"  )
 272                                  ]
 273
 274
 275 newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
 276 instance SysConfValue GlobalLock where
 277     confPath _      = "globalLock"
 278     serialize (GlobalLock isLocked)
 279         | isLocked  = "*"
 280         | otherwise = ""
 281     deserialize "*" = Just (GlobalLock True)
 282     deserialize ""  = Just (GlobalLock False)
 283     deserialize _   = Nothing
 284     defaultValue _  = GlobalLock False