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.Monad.Trans
  14 import qualified Data.ByteString.Char8 as C8
  15 import           Data.Maybe
  16 import           Network
  17 import qualified Network.HTTP.Lucu.Config as LC
  18 import           Network.URI
  19
  20
  21 data SystemConfig = SystemConfig {
  22       scLucuConf :: !LC.Config
  23     }
  24
  25
  26 data SysConfValue
  27     = SiteName String
  28     | BaseURI URI
  29     | StyleSheet String
  30
  31
  32 mkSystemConfig :: LC.Config -> SystemConfig
  33 mkSystemConfig = SystemConfig
  34
  35
  36 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
  37 getSysConf sc key
  38     = liftIO $ sysConfDefault sc key -- FIXME
  39
  40
  41 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
  42 getSysConfA = (arrIO0 .) . getSysConf
  43
  44
  45 {- paths -}
  46 sysConfPath :: SysConfValue -> FilePath
  47 sysConfPath (SiteName   _) = "/siteName"
  48 sysConfPath (BaseURI    _) = "/baseURI"
  49 sysConfPath (StyleSheet _) = "/styleSheet"
  50
  51
  52 {- marshalling -}
  53 marshalSysConf :: SysConfValue -> String
  54 marshalSysConf (SiteName   name) = name
  55 marshalSysConf (BaseURI    uri ) = uriToString id uri ""
  56 marshalSysConf (StyleSheet name) = name
  57
  58
  59 {- unmarshalling -}
  60 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
  61 unmarshalSysConf (SiteName   _) name = SiteName name
  62 unmarshalSysConf (BaseURI    _) uri  = BaseURI $ fromJust $ parseURI uri
  63 unmarshalSysConf (StyleSheet _) name = StyleSheet name
  64
  65
  66 {- getting default value -}
  67 sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
  68
  69 sysConfDefault _ (SiteName _)
  70     = return $ SiteName "Rakka"
  71
  72 sysConfDefault sc (BaseURI _)
  73     = do let conf = scLucuConf sc
  74              host = C8.unpack $ LC.cnfServerHost conf
  75              port = case LC.cnfServerPort conf of
  76                       PortNumber num -> fromIntegral num
  77
  78              defaultURI
  79                   = "http://" ++ host ++
  80                     (if port == 80
  81                      then ""
  82                      else ':' : show port) ++ "/"
  83
  84          return $ BaseURI $ fromJust $ parseURI defaultURI
  85
  86 sysConfDefault _ (StyleSheet _)
  87     = return $ StyleSheet "StyleSheet/Default"