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