Rakka/SystemConfig.hs

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