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