esotericbot-0.0.1: Esotericbot/Config.hs

{-# OPTIONS -XMagicHash #-}
module Esotericbot.Config where

import Control.Applicative

import Data.Tuple.Select
import Data.Tuple.Update
import Data.Attoparsec as A
import Data.List.Stream as L
import Data.Either
import qualified Data.ByteString.Lazy.Char8 as BSC
import qualified Data.ByteString.Lazy as BS
import Data.Maybe

import System.Posix.Types

import Control.Monad.Stream as C

import Esotericbot.BSUtils
import Esotericbot.EBTypes

data Var =
   SV SimpleVar
   | ListVar BS.ByteString [ BS.ByteString ]
   | ComplexVar BS.ByteString [ SimpleVar ]
   deriving ( Show , Eq )

data SimpleVar =
   SimpleVar BS.ByteString BS.ByteString
   deriving ( Show , Eq )
   
data ConfVar =
   Nick BS.ByteString
   | Pass BS.ByteString
   | Chans [ BS.ByteString ]
   | Server String
   | User CUid
   | MemLimit Integer
   | TimeLimit Integer -- where it is termed
   | HardTimeLimit Integer -- where it is killed
   | ChildrenMemLimit Integer
   | DefaultChildMemLimit Integer
   | OutputLimit Integer
   | Chroot String
   | CommandPrefix BS.ByteString
   | L Plugin
   deriving Show

-- Could this be done with pattern regex?
( Nick _ ) `same_var` ( Nick _ ) = True
( Pass _ ) `same_var` ( Pass _ ) = True
( Chans _ ) `same_var` ( Chans _ ) = True
( Server _ ) `same_var` ( Server _ ) = True
( User _ ) `same_var` ( User _ ) = True
( MemLimit _ ) `same_var` ( MemLimit _ ) = True
( TimeLimit _ ) `same_var` ( TimeLimit _ ) = True
( HardTimeLimit _ ) `same_var` ( HardTimeLimit _ ) = True
( ChildrenMemLimit _ ) `same_var` ( ChildrenMemLimit _ ) = True
( DefaultChildMemLimit _ ) `same_var` ( DefaultChildMemLimit _ ) = True
( OutputLimit _ ) `same_var` ( OutputLimit _ ) = True
( Chroot _ ) `same_var` ( Chroot _ ) = True
( L l1 ) `same_var` ( L l2 ) = prefix l1 == prefix l2
( CommandPrefix _ ) `same_var` ( CommandPrefix _ ) = True
_ `same_var` _ = False


type LangBuilder =
   ( Bool , Maybe String , Maybe BS.ByteString , Maybe BS.ByteString , Maybe Integer , Maybe BS.ByteString , Maybe BS.ByteString )

read_conf :: FilePath -> IO SmallBotConf
read_conf fp = do
   f <- BS.readFile fp
   let ( bs , vars ) = parse ( many $ conf_var ) f
   if BS.null bs
      then
         either ( error . (L.++) ( fp L.++ ": " ) . show )
                ( \ mlex_vars -> do
                   econfs <- C.mapM to_conf_var $ catMaybes mlex_vars
                   let leconfs = lefts econfs
                   if L.null leconfs
                      then
                        to_conf $ rights econfs
                      else do
                         putStrLn "Unknown settings: "             
                         C.mapM print leconfs
                         error "Invalid config file"
                )
                vars
      else do
         either print
                ( const $ return ( ) )
                vars
         error $ "Parse error in config file before:\n" L.++ ( L.take 50 $ bs2s bs ) L.++ "..."

to_conf conf_vars = do
   if contains_duplicates conf_vars -- are there any duplicates?
      then
         error "Configuration contains duplicate options!"
      else 
         maybe ( return $ L.foldl add_conf_var initial_state conf_vars )
               error
               valid_conf
   where
   is_default_child_mem_limit =
      same_var $ DefaultChildMemLimit undefined -- here, undefined should never be evaluated
   is_children_mem_limit =
      same_var $ ChildrenMemLimit undefined 
   -- perhaps weirdly, returning Nothing here means that the conf _is_ valid!
   valid_conf :: Maybe String
   valid_conf =
      let children_mem_test = 
             if contains_children_max_mem_limit
                then
                   if contains_child_default_mem_limit && contains_children_max_mem_limit
                      then Nothing
                      else Just "Configuration has 'children_mem_limit' but no 'default_child_mem_limit'\n( To limit the memory of all child processes, the esotericbot must know how much each process may be assigned - though admitedly, this is redundant if you manually specify the memory use for each plugin. )"
                else Nothing
          mandatory_ops_test =
             if contains_nick && contains_server
                then Nothing
                else Just "Configuration file must define _at_least_ the `nick` variable and the `server` variable.  See the README."
      in
         children_mem_test <|> mandatory_ops_test
   contains_nick = L.any is_nick conf_vars
   contains_server = L.any is_server conf_vars
   is_nick = same_var $ Nick undefined 
   is_server = same_var $ Server undefined
   contains_child_default_mem_limit = L.any is_default_child_mem_limit conf_vars
   contains_children_max_mem_limit = L.any is_children_mem_limit conf_vars
   add_conf_var st conf_var =
      case conf_var of
         Nick n ->
            st { nick = n }
         Pass p ->
            st { pass = p }
         Chans c ->
            st { chans = c }
         Server s ->
            st { server = s }
         Chroot ch ->
            st { chroot = Just ch }
         User u -> 
            st { user = Just u }
         MemLimit ml ->
            st { mmem_limit = Just ml }
         ChildrenMemLimit cml ->
            st { mchildren_mem_limit = Just cml }
         TimeLimit tl ->
            st { mtime_limit = Just tl }
         HardTimeLimit htl ->
            st { mhard_time_limit = Just htl }
         OutputLimit ol ->
            st { moutput_limit = Just $ fromIntegral ol }
         L plugin ->
            st { plugins = plugin : plugins st }
         DefaultChildMemLimit i ->
            st { default_child_mem_limit = Just i }
         CommandPrefix p ->
            st { command_prefix = p }

contains_duplicates l =
   L.any ( (<) 1 . L.length ) $ L.map ( \ i -> L.findIndices ( same_var i ) l ) l

to_conf_var var = do
   case var of
      SV sv@( SimpleVar var_name value ) -> do
         let simple_confs_unbox :: [ IO BS.ByteString ]
             simple_confs_unbox =
                [ 
                ls2bs 4 "nick"#
                , ls2bs 4 "pass"#
                , ls2bs 6 "server"#
                , ls2bs 6 "chroot"#
                , ls2bs 12 "command_prefix"#
                ]
             simple_conf_vals =
                [
                Nick value
                , Pass value
                , Server $ BSC.unpack value
                , Chroot $ BSC.unpack value
                , CommandPrefix value
                ]
             numeric_confs_unbox =
                [
                ls2bs 9 "mem_limit"#
                , ls2bs 10 "time_limit"#
                , ls2bs 15 "hard_time_limit"#
                , ls2bs 18 "children_mem_limit"#
                , ls2bs 12 "output_limit"#
                , ls2bs 23 "default_child_mem_limit"#
                , ls2bs 4 "user"#
                ]
             numeric_conf_vals i =
                [ MemLimit i
                , TimeLimit i
                , HardTimeLimit i
                , ChildrenMemLimit i
                , OutputLimit i
                , DefaultChildMemLimit i
                , User $ fromIntegral i
                ]
         simple_conf_names <- C.sequence simple_confs_unbox
         numeric_conf_names <- C.sequence numeric_confs_unbox
         let simple_confs :: [ ( BS.ByteString , ConfVar ) ] 
             simple_confs = L.zip simple_conf_names simple_conf_vals
             numeric_confs_waiting :: Integer -> [ ( BS.ByteString , ConfVar ) ]
             numeric_confs_waiting = L.zip numeric_conf_names . numeric_conf_vals
         return $ find_conf sv simple_confs numeric_confs_waiting
      lv@( ListVar var_name vars ) -> do
         cs <- ls2bs 5 "chans"#
         return $ if var_name == cs
                     then Right $ Chans vars
                     else Left lv
      cv@( ComplexVar var_name simple_vars ) -> do
         lang <- ls2bs 6 "plugin"#
         if var_name == lang
            then do
               cmd <- ls2bs 3 "cmd"#
               name <- ls2bs 4 "name"#
               prefix <- ls2bs 6 "prefix"#
               input_sep <- ls2bs 9 "input_sep"#
               memuse <- ls2bs 9 "mem_limit"#
               shortcut <- ls2bs 8 "shortcut"#
               let lang_table :: [ ( BS.ByteString , BS.ByteString -> LangBuilder -> LangBuilder ) ]
                   lang_table =
                      [ 
                      ( name , \ value -> with_failure_test sel6 $ upd6 $ Just value ) 
                      , ( cmd , \ value -> with_failure_test sel2 $ upd2 $ Just $ bs2s value )
                      , ( prefix , \ value -> with_failure_test sel3 $ upd3 $ Just value )
                      , ( input_sep , \ value -> with_failure_test sel4 $ upd4 $ Just value )
                      , ( memuse , \ value st -> maybe ( fail st ) ( \ ( i , bs ) -> with_failure_test sel5 ( upd5 $ Just i ) st ) $ BSC.readInteger value )
                      , ( shortcut , \ value -> with_failure_test sel7 $ upd7 $ Just value ) 
                      ]
                   lang_builder :: LangBuilder
                   lang_builder = ( False , Nothing , Nothing , Nothing , Nothing , Nothing , Nothing )
                   with_failure_test f g st =
                      if sel1 st
                         then st
                         else maybe ( g st ) ( const $ fail st ) $ f st
                   fail :: LangBuilder -> LangBuilder
                   fail = upd1 True
                   vars :: LangBuilder
                   vars = L.foldl ( \ lb ( SimpleVar name val ) ->
                                     maybe ( fail lb )
                                           ( \ f -> f val lb )
                                           $ L.lookup name lang_table
                                  ) lang_builder simple_vars
               case vars of
                  ( False , Just cmd , Just prefix , minput_sep , mmem_use , Just name , shortcut ) ->
                     return $ Right $ L $ Plugin cmd prefix minput_sep mmem_use name shortcut
                  _ ->
                    return $ Left cv 
            else
               return $ Left cv
   where
   find_conf :: SimpleVar -> [ ( BS.ByteString , ConfVar ) ] -> ( Integer -> [ ( BS.ByteString , ConfVar ) ] ) -> Either Var ConfVar
   find_conf sv@( SimpleVar var_name value ) simple_confs numeric_confs_waiting = do
      maybe ( Left $ SV sv )
            Right
            $ L.lookup var_name simple_confs <|> do ( i , _ ) <- BSC.readInteger value
                                                    let numeric_confs = numeric_confs_waiting i
                                                    L.lookup var_name numeric_confs


conf_var =
   try ( comment <?> "Comment" ) 
       <|>
       ( try ( fmap Just l_var <?> "List var" )
             <|>
             ( try ( complex_var <?> "Complex var" ) 
                   <|>
                   ( ( fmap ( Just . SV ) simple_var ) <?> "Simple var" )
             ) 
       )

comment = do
   word8 45
   word8 45 
   takeTill $ (==) 10 
   spaces
   return Nothing

label c =
   A.takeWhile $ flip L.notElem $ c : space_word8s

l_var = do
   spaces
   var_name <- label 61
   spaces
   word8 61
   spaces
   word8 91
   elems <- sepBy1 list_elem $ do spaces
                                  word8 44
   spaces
   word8 93
   spaces
   return $ ListVar var_name elems

list_elem = do
   spaces
   word8 34
   e <- takeTill $ (==) 34
   word8 34
   return e

simple_var = do
   spaces
   var_name <- label 61
   spaces
   word8 61
   spaces
   word8 34
   value <- takeTill $ (==) 34
   word8 34
   spaces
   return $ SimpleVar var_name value

complex_var = do
   spaces
   var_name <- label 123 
   spaces
   word8 123
   spaces
   simple_vars <- fmap lefts $ many $ eitherP simple_var comment
   spaces
   word8 125
   spaces
   return $ Just $ ComplexVar var_name simple_vars