module Hascat.Config where
import Text.XML.HaXml.Xml2Haskell
import Text.XML.HaXml.OneOfN
import Char (isSpace)
import Data.List
import Data.Maybe
data Config = Config Config_Attrs General AppController
deriving (Eq,Show)
data Config_Attrs = Config_Attrs
{ configVersion :: String
} deriving (Eq,Show)
data General = General Port ServerRoot PluginLoader
deriving (Eq,Show)
newtype Port = Port Int deriving (Eq,Show)
newtype ServerRoot = ServerRoot String deriving (Eq,Show)
data PluginLoader = PluginLoader [IncludePath] [PkgConfFile]
deriving (Eq,Show)
newtype IncludePath = IncludePath String deriving (Eq,Show)
newtype PkgConfFile = PkgConfFile String deriving (Eq,Show)
newtype AppController = AppController [AppConfig] deriving (Eq,Show)
data AppConfig = AppConfig {
appAttr :: AppConfig_Attrs,
appName :: Name,
appDesc :: Description,
appRoot :: Root,
appCode :: Code,
appContextPath :: ContextPath,
appInitTimeOut :: InitTimeout,
appResponseTimeOut :: RespondTimeout,
appDoneTimeOut :: DoneTimeout }
deriving (Eq,Show)
data AppConfig_Attrs = AppConfig_Attrs {
appConfigType :: Maybe AppConfig_type,
appConfigAutoStart :: Maybe AppConfig_autoStart }
deriving (Eq,Show)
data AppConfig_type = AppConfig_type_normal |
AppConfig_type_system
deriving (Eq,Show)
data AppConfig_autoStart = AppConfig_autoStart_yes |
AppConfig_autoStart_no
deriving (Eq,Show)
newtype Name = Name String deriving (Eq,Show)
newtype Description = Description String deriving (Eq,Show)
newtype Root = Root String deriving (Eq,Show)
newtype Code = Code String deriving (Eq,Show)
newtype ContextPath = ContextPath String deriving (Eq)
newtype InitTimeout = InitTimeout Int deriving (Eq,Show)
newtype RespondTimeout = RespondTimeout Int deriving (Eq,Show)
newtype DoneTimeout = DoneTimeout Int deriving (Eq,Show)
instance Show ContextPath where
show (ContextPath contextPath) = contextPath
instance XmlContent Config where
fromElem (CElem (Elem "config" as c0):rest) =
(\(a,ca)->
(\(b,cb)->
(Just (Config (fromAttrs as) a b), rest))
(definite fromElem "<appController>" "config" ca))
(definite fromElem "<general>" "config" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Config as a b) =
[CElem (Elem "config" (toAttrs as) (toElem a ++ toElem b))]
instance XmlAttributes Config_Attrs where
fromAttrs as =
Config_Attrs
{ configVersion = definiteA fromAttrToStr "config" "version" as
}
toAttrs v = catMaybes
[ toAttrFrStr "version" (configVersion v)
]
instance XmlContent General where
fromElem (CElem (Elem "general" [] c0):rest) =
(\(a,ca)->
(\(b,cb)->
(\(c,cc)->
(Just (General a b c), rest))
(definite fromElem "<pluginLoader>" "general" cb))
(definite fromElem "<serverRoot>" "general" ca))
(definite fromElem "<port>" "general" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (General a b c) =
[CElem (Elem "general" [] (toElem a ++ toElem b ++ toElem c))]
instance XmlContent Port where
fromElem (CElem (Elem "port" [] c0):rest) =
(\(a,ca)->
(Just (Port a), rest))
(definite (toInt . fromText) "int" "port" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Port a) =
[CElem (Elem "port" [] (toText (fromInt a)))]
instance XmlContent ServerRoot where
fromElem (CElem (Elem "serverRoot" [] c0):rest) =
(\(a,ca)->
(Just (ServerRoot a), rest))
(definite fromText "text" "serverRoot" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (ServerRoot a) =
[CElem (Elem "serverRoot" [] (toText a))]
instance XmlContent PluginLoader where
fromElem (CElem (Elem "pluginLoader" [] c0):rest) =
(\(a,ca)->
(\(b,cb)->
(Just (PluginLoader a b), rest))
(many fromElem ca))
(many fromElem c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (PluginLoader a b) =
[CElem (Elem "pluginLoader" [] (concatMap toElem a ++
concatMap toElem b))]
instance XmlContent IncludePath where
fromElem (CElem (Elem "includePath" [] c0):rest) =
(\(a,ca)->
(Just (IncludePath a), rest))
(definite fromText "text" "includePath" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (IncludePath a) =
[CElem (Elem "includePath" [] (toText a))]
instance XmlContent PkgConfFile where
fromElem (CElem (Elem "pkgConfFile" [] c0):rest) =
(\(a,ca)->
(Just (PkgConfFile a), rest))
(definite fromText "text" "pkgConfFile" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (PkgConfFile a) =
[CElem (Elem "pkgConfFile" [] (toText a))]
instance XmlContent AppController where
fromElem (CElem (Elem "appController" [] c0):rest) =
(\(a,ca)->
(Just (AppController a), rest))
(many fromElem c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (AppController a) =
[CElem (Elem "appController" [] (concatMap toElem a))]
instance XmlContent AppConfig where
fromElem (CElem (Elem "appConfig" as c0):rest) =
(\(a,ca)->
(\(b,cb)->
(\(c,cc)->
(\(d,cd)->
(\(e,ce)->
(\(f,cf)->
(\(g,cg)->
(\(h,ch)->
(Just (AppConfig (fromAttrs as) a b c d e f g h), rest))
(definite fromElem "<doneTimeout>" "appConfig" cg))
(definite fromElem "<respondTimeout>" "appConfig" cf))
(definite fromElem "<initTimeout>" "appConfig" ce))
(definite fromElem "<contextPath>" "appConfig" cd))
(definite fromElem "<code>" "appConfig" cc))
(definite fromElem "<root>" "appConfig" cb))
(definite fromElem "<description>" "appConfig" ca))
(definite fromElem "<name>" "appConfig" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (AppConfig as a b c d e f g h) =
[CElem (Elem "appConfig" (toAttrs as) (toElem a ++ toElem b ++
toElem c ++ toElem d ++ toElem e ++ toElem f ++
toElem g ++ toElem h))]
instance XmlAttributes AppConfig_Attrs where
fromAttrs as =
AppConfig_Attrs
{ appConfigType = possibleA fromAttrToTyp "type" as
, appConfigAutoStart = possibleA fromAttrToTyp "autoStart" as
}
toAttrs v = catMaybes
[ maybeToAttr toAttrFrTyp "type" (appConfigType v)
, maybeToAttr toAttrFrTyp "autoStart" (appConfigAutoStart v)
]
instance XmlAttrType AppConfig_type where
fromAttrToTyp n (n',v)
| n==n' = translate (attr2str v)
| otherwise = Nothing
where translate "normal" = Just AppConfig_type_normal
translate "system" = Just AppConfig_type_system
translate _ = Nothing
toAttrFrTyp n AppConfig_type_normal = Just (n, str2attr "normal")
toAttrFrTyp n AppConfig_type_system = Just (n, str2attr "system")
instance XmlAttrType AppConfig_autoStart where
fromAttrToTyp n (n',v)
| n==n' = translate (attr2str v)
| otherwise = Nothing
where translate "yes" = Just AppConfig_autoStart_yes
translate "no" = Just AppConfig_autoStart_no
translate _ = Nothing
toAttrFrTyp n AppConfig_autoStart_yes = Just (n, str2attr "yes")
toAttrFrTyp n AppConfig_autoStart_no = Just (n, str2attr "no")
instance XmlContent Name where
fromElem (CElem (Elem "name" [] c0):rest) =
(\(a,ca)->
(Just (Name a), rest))
(definite fromText "text" "name" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Name a) =
[CElem (Elem "name" [] (toText a))]
instance XmlContent Description where
fromElem (CElem (Elem "description" [] c0):rest) =
(\(a,ca)->
(Just (Description a), rest))
(definite fromText "text" "description" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Description a) =
[CElem (Elem "description" [] (toText a))]
instance XmlContent Root where
fromElem (CElem (Elem "root" [] c0):rest) =
(\(a,ca)->
(Just (Root a), rest))
(definite fromText "text" "root" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Root a) =
[CElem (Elem "root" [] (toText a))]
instance XmlContent Code where
fromElem (CElem (Elem "code" [] c0):rest) =
(\(a,ca)->
(Just (Code a), rest))
(definite fromText "text" "code" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (Code a) =
[CElem (Elem "code" [] (toText a))]
instance XmlContent ContextPath where
fromElem (CElem (Elem "contextPath" [] c0):rest) =
(\(a,ca)->
(Just (ContextPath a), rest))
(definite fromText "text" "contextPath" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (ContextPath a) =
[CElem (Elem "contextPath" [] (toText a))]
instance XmlContent InitTimeout where
fromElem (CElem (Elem "initTimeout" [] c0):rest) =
(\(a,ca)->
(Just (InitTimeout a), rest))
(definite (toInt . fromText) "int" "initTimeout" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (InitTimeout a) =
[CElem (Elem "initTimeout" [] (toText (fromInt a)))]
instance XmlContent RespondTimeout where
fromElem (CElem (Elem "respondTimeout" [] c0):rest) =
(\(a,ca)->
(Just (RespondTimeout a), rest))
(definite (toInt . fromText) "int" "respondTimeout" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (RespondTimeout a) =
[CElem (Elem "respondTimeout" [] (toText (fromInt a)))]
instance XmlContent DoneTimeout where
fromElem (CElem (Elem "doneTimeout" [] c0):rest) =
(\(a,ca)->
(Just (DoneTimeout a), rest))
(definite (toInt . fromText) "int" "doneTimeout" c0)
fromElem (CMisc _:rest) = fromElem rest
fromElem (CString _ s:rest) | all isSpace s = fromElem rest
fromElem rest = (Nothing, rest)
toElem (DoneTimeout a) =
[CElem (Elem "doneTimeout" [] (toText (fromInt a)))]
fromInt :: Int -> String
fromInt = show
toInt :: (Maybe String, [Content]) -> (Maybe Int, [Content])
toInt (Nothing, rest) = (Nothing, rest)
toInt (Just s, rest) = case reads s of
[(n, _)] -> (Just n, rest)
_ -> (Nothing, rest)
getPort :: General -> Int
getPort (General (Port port) _ _) = port
getServerRoot :: General -> FilePath
getServerRoot (General _ (ServerRoot root) _) = root
getPluginLoader :: General -> PluginLoader
getPluginLoader (General _ _ loader) = loader
getIncludePaths :: PluginLoader -> [FilePath]
getIncludePaths (PluginLoader elements _) =
map (\(IncludePath path) -> path) elements
getPkgConfFiles :: PluginLoader -> [FilePath]
getPkgConfFiles (PluginLoader _ elements) =
map (\(PkgConfFile file) -> file) elements
getAppType :: AppConfig -> AppConfig_type
getAppType (AppConfig attrs _ _ _ _ _ _ _ _) =
fromMaybe AppConfig_type_normal (appConfigType attrs)
getAppAutoStart :: AppConfig -> AppConfig_autoStart
getAppAutoStart (AppConfig attrs _ _ _ _ _ _ _ _) =
fromMaybe AppConfig_autoStart_yes (appConfigAutoStart attrs)
getAppName :: AppConfig -> String
getAppName (AppConfig _ (Name name) _ _ _ _ _ _ _) = name
getAppDescription :: AppConfig -> String
getAppDescription (AppConfig _ _ (Description description) _ _ _ _ _ _) =
description
getAppRoot :: AppConfig -> FilePath
getAppRoot (AppConfig _ _ _ (Root root) _ _ _ _ _) = root
getAppCode :: AppConfig -> FilePath
getAppCode (AppConfig _ _ _ _ (Code code) _ _ _ _) = code
getAppContextPath :: AppConfig -> ContextPath
getAppContextPath (AppConfig _ _ _ _ _ (ContextPath contextPath) _ _ _) =
if "/" `isSuffixOf` contextPath then (ContextPath contextPath)
else (ContextPath $ contextPath ++ "/")
getAppInitTimeout :: AppConfig -> Int
getAppInitTimeout (AppConfig _ _ _ _ _ _ (InitTimeout timeout) _ _) = timeout
getAppRespondTimeout :: AppConfig -> Int
getAppRespondTimeout (AppConfig _ _ _ _ _ _ _ (RespondTimeout timeout) _) =
timeout
getAppDoneTimeout :: AppConfig -> Int
getAppDoneTimeout (AppConfig _ _ _ _ _ _ _ _ (DoneTimeout timeout)) = timeout