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
  32
  33 data SystemConfig = SystemConfig {
  34       scLucuConf   :: !LC.Config
  35     , scRepository :: !Repository
  36     , scCache      :: !(TVar (Map FilePath SysConfValue))
  37     }
  38
  39
  40 data SysConfValue
  41     = SiteName String
  42     | BaseURI URI
  43     | DefaultPage String
  44     | StyleSheet String
  45     deriving (Eq, Show)
  46
  47
  48 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
  49 mkSystemConfig lc repos
  50     = do cache <- newTVarIO M.empty
  51          return $ SystemConfig {
  52                       scLucuConf   = lc
  53                     , scRepository = repos
  54                     , scCache      = cache
  55                     }
  56
  57
  58 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
  59 getSysConf sc key
  60     = liftIO $
  61       atomically $
  62       do let path = sysConfPath key
  63
  64          cache <- readTVar (scCache sc)
  65
  66          case M.lookup path cache of
  67            Just val -> return val
  68            Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc key)
  69                           writeTVar (scCache sc) (M.insert path val cache)
  70                           return val
  71
  72
  73 getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
  74 getSysConf' sc key
  75     = do fs    <- getRepositoryFS (scRepository sc)
  76          rev   <- getYoungestRev fs
  77          value <- withRevision fs rev
  78                   $ do let path = fromConfPath (sysConfPath key)
  79                        exists <- isFile path
  80                        case exists of
  81                          True
  82                              -> do str <- getFileContentsLBS path
  83                                    return $ Just $ chomp $ decodeLazy UTF8 str
  84                          False
  85                              -> return Nothing
  86          case value of
  87            Just str -> return $ unmarshalSysConf key str
  88            Nothing  -> sysConfDefault sc key
  89
  90
  91 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
  92 getSysConfA = (arrIO0 .) . getSysConf
  93
  94
  95 fromConfPath :: FilePath -> FilePath
  96 fromConfPath = combine "/config"
  97
  98
  99 {- paths -}
 100 sysConfPath :: SysConfValue -> FilePath
 101 sysConfPath (SiteName    _) = "siteName"
 102 sysConfPath (BaseURI     _) = "baseURI"
 103 sysConfPath (DefaultPage _) = "defaultPage"
 104 sysConfPath (StyleSheet  _) = "styleSheet"
 105
 106
 107 {- marshalling -}
 108 marshalSysConf :: SysConfValue -> String
 109 marshalSysConf (SiteName    name) = name
 110 marshalSysConf (BaseURI     uri ) = uriToString id uri ""
 111 marshalSysConf (DefaultPage name) = name
 112 marshalSysConf (StyleSheet  name) = name
 113
 114
 115 {- unmarshalling -}
 116 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
 117 unmarshalSysConf (SiteName    _) name = SiteName name
 118 unmarshalSysConf (BaseURI     _) uri  = BaseURI $ fromJust $ parseURI uri
 119 unmarshalSysConf (DefaultPage _) name = DefaultPage name
 120 unmarshalSysConf (StyleSheet  _) name = StyleSheet name
 121
 122
 123 {- getting default value -}
 124 sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
 125
 126 sysConfDefault _ (SiteName _)
 127     = return $ SiteName "Rakka"
 128
 129 sysConfDefault sc (BaseURI _)
 130     = do let conf = scLucuConf sc
 131              host = C8.unpack $ LC.cnfServerHost conf
 132              port = case LC.cnfServerPort conf of
 133                       PortNumber num -> fromIntegral num
 134
 135              defaultURI
 136                   = "http://" ++ host ++
 137                     (if port == 80
 138                      then ""
 139                      else ':' : show port) ++ "/"
 140
 141          return $ BaseURI $ fromJust $ parseURI defaultURI
 142
 143 sysConfDefault _ (DefaultPage _)
 144     = return $ DefaultPage "MainPage"
 145
 146 sysConfDefault _ (StyleSheet _)
 147     = return $ StyleSheet "StyleSheet/Default"