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