module Hascat.Config where

import Text.XML.HaXml.Xml2Haskell
import Text.XML.HaXml.OneOfN
import Char (isSpace)

import Data.List
import Data.Maybe


{-Type decls-}

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 decls-}

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)))]


{-Done-}



{-Int Conversion-}

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)


{- Getter -}

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