Rakka/SystemConfig.hs

   1 module Rakka.SystemConfig
   2     ( SystemConfig
   3     , SysConfValue(..)
   4
   5     , mkSystemConfig -- private
   6
   7     , getSysConf
   8     , getSysConfA
   9     )
  10     where
  11
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Concurrent.STM
  14 import           Control.Monad.Trans
  15 import qualified Data.ByteString.Char8 as C8
  16 import           Data.Encoding
  17 import           Data.Encoding.UTF8
  18 import           Data.Map (Map)
  19 import qualified Data.Map as M
  20 import           Data.Maybe
  21 import           GHC.Conc (unsafeIOToSTM)
  22 import           Network
  23 import qualified Network.HTTP.Lucu.Config as LC
  24 import           Network.URI
  25 import           Rakka.Utils
  26 import           Subversion.FileSystem
  27 import           Subversion.FileSystem.Revision
  28 import           Subversion.FileSystem.Root
  29 import           Subversion.Repository
  30 import           System.FilePath.Posix
  31 import           System.Log.Logger
  32
  33 logger = "Rakka.SystemConfig"
  34
  35
  36 data SystemConfig = SystemConfig {
  37       scLucuConf   :: !LC.Config
  38     , scRepository :: !Repository
  39     , scCache      :: !(TVar (Map FilePath SysConfValue))
  40     }
  41
  42
  43 data SysConfValue
  44     = SiteName String
  45     | BaseURI URI
  46     | DefaultPage String
  47     | StyleSheet String
  48     deriving (Eq, Show)
  49
  50
  51 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
  52 mkSystemConfig lc repos
  53     = do cache <- newTVarIO M.empty
  54          return $ SystemConfig {
  55                       scLucuConf   = lc
  56                     , scRepository = repos
  57                     , scCache      = cache
  58                     }
  59
  60
  61 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
  62 getSysConf sc key
  63     = liftIO $
  64       atomically $
  65       do let path = sysConfPath key
  66
  67          cache <- readTVar (scCache sc)
  68
  69          case M.lookup path cache of
  70            Just val -> return val
  71            Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc key)
  72                           writeTVar (scCache sc) (M.insert path val cache)
  73                           return val
  74
  75
  76 getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
  77 getSysConf' sc key
  78     = do let path = fromConfPath (sysConfPath key)
  79
  80          fs    <- getRepositoryFS (scRepository sc)
  81          rev   <- getYoungestRev fs
  82          value <- withRevision fs rev
  83                   $ do exists <- isFile path
  84                        case exists of
  85                          True
  86                              -> do str <- getFileContentsLBS path
  87                                    return $ Just $ chomp $ decodeLazy UTF8 str
  88                          False
  89                              -> return Nothing
  90
  91          case value of
  92            Just str
  93                -> do let val = unmarshalSysConf key str
  94                      debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
  95                      return val
  96            Nothing
  97                -> do val <- sysConfDefault sc key
  98                      debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
  99                      return val
 100
 101
 102 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
 103 getSysConfA = (arrIO0 .) . getSysConf
 104
 105
 106 fromConfPath :: FilePath -> FilePath
 107 fromConfPath = combine "/config"
 108
 109
 110 {- paths -}
 111 sysConfPath :: SysConfValue -> FilePath
 112 sysConfPath (SiteName    _) = "siteName"
 113 sysConfPath (BaseURI     _) = "baseURI"
 114 sysConfPath (DefaultPage _) = "defaultPage"
 115 sysConfPath (StyleSheet  _) = "styleSheet"
 116
 117
 118 {- marshalling -}
 119 marshalSysConf :: SysConfValue -> String
 120 marshalSysConf (SiteName    name) = name
 121 marshalSysConf (BaseURI     uri ) = uriToString id uri ""
 122 marshalSysConf (DefaultPage name) = name
 123 marshalSysConf (StyleSheet  name) = name
 124
 125
 126 {- unmarshalling -}
 127 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
 128 unmarshalSysConf (SiteName    _) name = SiteName name
 129 unmarshalSysConf (BaseURI     _) uri  = BaseURI $ fromJust $ parseURI uri
 130 unmarshalSysConf (DefaultPage _) name = DefaultPage name
 131 unmarshalSysConf (StyleSheet  _) name = StyleSheet name
 132
 133
 134 {- getting default value -}
 135 sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
 136
 137 sysConfDefault _ (SiteName _)
 138     = return $ SiteName "Rakka"
 139
 140 sysConfDefault sc (BaseURI _)
 141     = do let conf = scLucuConf sc
 142              host = C8.unpack $ LC.cnfServerHost conf
 143              port = case LC.cnfServerPort conf of
 144                       PortNumber num -> fromIntegral num
 145
 146              defaultURI
 147                   = "http://" ++ host ++
 148                     (if port == 80
 149                      then ""
 150                      else ':' : show port) ++ "/"
 151
 152          return $ BaseURI $ fromJust $ parseURI defaultURI
 153
 154 sysConfDefault _ (DefaultPage _)
 155     = return $ DefaultPage "MainPage"
 156
 157 sysConfDefault _ (StyleSheet _)
 158     = return $ StyleSheet "StyleSheet/Default"