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