Index: DociGateway/src/MobileGateway/Util/Config.hs =================================================================== --- DociGateway.orig/src/MobileGateway/Util/Config.hs 2010-09-22 11:05:26.000000000 +0200 +++ DociGateway/src/MobileGateway/Util/Config.hs 2010-09-22 11:14:21.000000000 +0200 @@ -1,19 +1,19 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module MobileGateway.Util.Config - (Cfg(..), ServiceCfg(..), TcpServiceCfg(..), WebServiceCfg(..), LogCfg(..) - , getUrl, getWebPort, getTcpPort, getConfig, getConfigWithSections, updateSvcCfgWithArgs - , getReferencedService, defaultLogCfg -) where + where ---------------------------------------- -- STDLIB ---------------------------------------- -import Control.Monad (liftM, mplus) +import Control.Monad (liftM, mplus, when) import Control.Monad.Error (MonadError, catchError) import Control.Monad.Writer (WriterT, runWriterT, tell) import Control.Monad.State (StateT, runStateT, execStateT, modify) import Control.Monad.Trans (lift) import Control.Monad.Fix (mfix) +import Control.Monad.Error (MonadError, Error, runErrorT, throwError, catchError) import Data.Char (toUpper) import Data.Maybe (fromMaybe) @@ -28,6 +28,8 @@ import qualified System.Environment as Env import qualified System.Posix.User as User +import Debug.Trace + ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- @@ -42,7 +44,8 @@ ---------------------------------------- -- LOCAL ---------------------------------------- -import MobileGateway.Util.Misc (errorToMaybe, errorToDefault) + +import MobileGateway.Util.Misc _DEFAULTS_SECTION_ = "DEFAULTS" @@ -50,6 +53,7 @@ -- , svcCfg_pollIntervalSeconds :: Maybe Int -- + data LogCfg = LogCfg { logCfg_file :: Maybe String , logCfg_level :: Priority } @@ -83,33 +87,30 @@ parseConfig :: [String] -> (String -> String) -> Cfg.ConfigParser -> Either Cfg.CPError (Cfg, [ServiceCfg]) parseConfig serviceNames repl cp = - do prot <- liftM repl $ errorToDefault "http" $ Cfg.get cp "DEFAULTS" "web-protocol" - host <- liftM repl $ errorToDefault "localhost" $ Cfg.get cp "DEFAULTS" "web-host" - mport <- errorToMaybe $ Cfg.get cp "DEFAULTS" "web-port" - port <- - case mport of - Just portstr -> parsePort portstr - Nothing -> return 80 - prefix <- liftM repl $ errorToDefault "" $ Cfg.get cp "DEFAULTS" "web-prefix" - let defaults = (prot,host,port,prefix) + do prot <- return undefined + host <- return undefined + port <- return undefined + prefix <- return undefined + let defaults = undefined serviceSects = filter (/=_DEFAULTS_SECTION_) (Cfg.sections cp) + -- No crash if hard-wiring the results: + -- let serviceSects = ["DerivationGateway","FastCgiDataServer","FastCgiDerivationServer","LubSyncClient","Mantis","MobileGateway","SalviaDataServer","SalviaDerivationGateway","SalviaDerivationServer","VDataServer"] serviceMap <- mfix $ \serviceMap -> do services <- mapM (parseServiceCfg serviceMap) serviceSects return (zip serviceSects services) services <- mapM (getService serviceMap) serviceNames - return (Cfg serviceMap defaults, services) + return undefined where consume section name = Cfg.get cp section name >>= \x -> tell [name] >> return x parseServiceCfg :: [(String, ServiceCfg)] -> String -> Either Cfg.CPError ServiceCfg parseServiceCfg serviceMap section = do let parsePredefined = - do webSvc <- parseWebCfg section + do -- Removing any of the following lines prevents a crash + webSvc <- return undefined tcpSvc <- parseTcpCfg section logCfg <- parseLogCfg section - --pollinterval <- errorToMaybe (Cfg.get cp section "pollinterval") - -- >>= parsePollInterval - return (ServiceCfg section logCfg webSvc tcpSvc) + return undefined (mkServiceCfg, usedItems) <- runWriterT parsePredefined allItems <- Cfg.items cp section let svcPrefix = "Service-" @@ -127,33 +128,18 @@ let upd x = x { logCfg_file = logfile `mplus` logCfg_file x , logCfg_level = fromMaybe (logCfg_level x) loglevel } + -- This prevents a crash: + -- let upd x = x return (upd defaultLogCfg) - parseTcpCfg section = + parseTcpCfg section = if False then return undefined else + -- Commenting out this prevents a crash do host <- liftM (fromMaybe "localhost") $ errorToMaybe (consume section "tcp-host") - mportstr <- errorToMaybe $ consume section "tcp-port" + (mportstr :: Maybe String) <- errorToMaybe $ consume section "tcp-port" case mportstr of Just portstr -> do port <- parsePort portstr return (Just $ TcpServiceCfg port host) Nothing -> return Nothing - parseWebCfg section = - do mprot <- errorToMaybe (liftM repl $ consume section "web-protocol") - mhost <- errorToMaybe (liftM repl $ consume section "web-host") - mport' <- errorToMaybe (liftM repl $ consume section "web-port") - mport <- - case mport' of - Nothing -> return Nothing - Just portstr -> liftM Just $ parsePort portstr - mprefix <- errorToMaybe (liftM repl $ consume section "web-prefix") - mpath <- errorToMaybe $ consume section "web-path" - case mpath of - Just path -> return (Just $ WebServiceCfg mprot mhost mport mprefix path) - Nothing -> return Nothing - parsePort :: Monad m => String -> m Int - parsePort portstr = - case readMay portstr of - Just port -> return port - Nothing -> fail $ "Not a valid port number: " ++ portstr parsePollInterval Nothing = return Nothing parsePollInterval (Just s) = case readMay s of @@ -164,135 +150,37 @@ Just svc -> return svc Nothing -> fail ("Service `" ++ svcName ++ "' needed but not defined anywhere.") +parsePort :: Monad m => String -> m Int +parsePort portstr = do + -- Tracing the portstr prevents the crash + -- trace portstr (return ()) + case readMay portstr of + Just port -> return port + Nothing -> fail $ "Not a valid port number: " ++ portstr + parseLogLevel :: Monad m => String -> m Priority -parseLogLevel level = - case (map toUpper) level of - "TRACE" -> return DEBUG - "DEBUG" -> return INFO - "INFO" -> return NOTICE - "WARN" -> return WARNING - "WARNING" -> return WARNING - "ERROR" -> return ERROR - _ -> fail $ "Failed to parse log-level `" ++ level ++ "'!" +parseLogLevel level = return undefined getConfig getDataFileName = do (cfg, []) <- getConfigWithSections getDataFileName [] return cfg -getConfigWithSections getDataFileName sections = +getConfigWithSections getDataFileName sections = do readConfig getDataFileName "MobileGateway.ini" (parseConfig sections) -getUrl :: Cfg -> ServiceCfg -> String -getUrl (Cfg { cfg_defaults = (defProt, defHost, defPort, defPrefix)}) - svcCfg@(ServiceCfg - { svcCfg_webCfg = - Just (WebServiceCfg { wsCfg_prot = mprot, wsCfg_host = mhost - , wsCfg_prefix = mprefix, wsCfg_path = path - , wsCfg_port = mport })}) - = let prot = fromMaybe defProt mprot - host = fromMaybe defHost mhost - prefix = fromMaybe defPrefix mprefix - port = fromMaybe defPort mport - portstr = if port == 80 then "" else ':' : show port - in prot ++ "://" ++ (host ++ portstr prefix path) -getUrl _ _ = error "Configuration doesn't include web service configuration." - -getWebPort :: ServiceCfg -> Maybe Int -getWebPort svcCfg = - do webCfg <- svcCfg_webCfg svcCfg - wsCfg_port webCfg - -getTcpPort :: ServiceCfg -> Maybe Int -getTcpPort svcCfg = - do tcpCfg <- svcCfg_tcpCfg svcCfg - return $ tcpCfg_port tcpCfg -- == GENERAL FUNCTION ======================================================== - -getHomeDir :: IO FilePath -getHomeDir = - do uid <- User.getEffectiveUserID - liftM User.homeDirectory (User.getUserEntryForID uid) - -getUser :: IO String -getUser = - do uid <- User.getEffectiveUserID - liftM User.userName (User.getUserEntryForID uid) - - -findConfig :: (String -> IO String) -> String -> IO FilePath -findConfig getDataFileName confName = - do progDir <- liftM takeDirectory Env.getProgName >>= Dir.canonicalizePath - homeDir <- getHomeDir - curDir <- Dir.getCurrentDirectory >>= Dir.canonicalizePath - defaultLoc <- getDataFileName confName - let locs = [dir confName | dir <- [curDir, progDir, homeDir]] ++ [defaultLoc] - find [] = fail ("No configuration file found. The following " - ++ "locations were searched: " - ++ concat (intersperse ", " locs)) - find (x:xs) = do ex <- Dir.doesFileExist x - if ex then return x else find xs - find locs - +readConfig :: (String -> IO String) -> String -> ((String -> String) -> Cfg.ConfigParser -> Either Cfg.CPError (Cfg, [ServiceCfg])) -> IO (Cfg,[ServiceCfg]) readConfig getDataFileName confName parseCfg = - do cfgFile <- findConfig getDataFileName confName - repls <- getReplacements + do curDir <- Dir.getCurrentDirectory >>= Dir.canonicalizePath + -- cfgFile <- findConfig getDataFileName confName + let cfgFile = "./MobileGateway.ini" + let cfgFile = curDir "MobileGateway.ini" hPutStrLn stderr $ "Reading config file `"++cfgFile++"'..." mcfg <- Cfg.readfile Cfg.emptyCP cfgFile - let showErr ty arg src = fail ("Error parsing config file `" ++ cfgFile - ++ "' at " ++ src ++ ":\n" - ++ ty ++ ": " ++ arg) - case mcfg >>= parseCfg (applyRepls repls) of - Left (Cfg.ParseError msg, src) -> showErr "ParseError" msg src - Left (Cfg.NoSection sec, src) -> showErr "NoSection" sec src - Left (Cfg.NoOption opt, src) -> showErr "NoOption" opt src - Left (Cfg.SectionAlreadyExists msg, src) -> - showErr "DuplicateSection" msg src - Left (Cfg.OtherProblem msg, src) -> showErr "Error" msg src - Left (Cfg.InterpolationError msg, src) -> showErr "Error" msg src - Right cfg -> - do hPutStrLn stderr $ "Got configuration." - return cfg - where - applyRepls (home,user) = replace "$HOME" home . replace "$USER" user - getReplacements = - do home <- getHomeDir - user <- getUser - return (home,user) - -getReferencedService :: ServiceCfg -> String -> IO ServiceCfg -getReferencedService sect@(ServiceCfg { svcCfg_services = serviceMap }) svcName = - case lookup svcName serviceMap of - Just svc -> return svc - Nothing -> fail ("Service `" ++ svcCfg_name sect ++ - "' doesn't have a service reference to `" ++ svcName ++ "'.") - -updateSvcCfgWithArgs :: forall s. - [OptDescr (StateT s IO ())] - -> s - -> ServiceCfg - -> [String] - -> IO (s, ServiceCfg, [String]) -updateSvcCfgWithArgs moreOpts s svcCfg args = - do progName <- Env.getProgName - case getOpt RequireOrder options args of - (actions, nonOpts, []) -> - do (svcCfg', s') <- runStateT (execStateT (sequence_ actions) svcCfg) s - return (s', svcCfg', nonOpts) - (_, _, msgs) -> error $ concat msgs ++ usageInfo (header progName) options - where - options :: [OptDescr (StateT ServiceCfg (StateT s IO) ())] - options = - [ (Option [] ["log-level"] (ReqArg setLogLevel "LOGLEVEL") - "override log-level from config file") - ] ++ map mapOpt moreOpts - header progName = "Usage: " ++ progName ++ " [OPTION...]" - setLogLevel newLevelStr = - do newLogLevel <- parseLogLevel newLevelStr - modify (\cfg -> - cfg { svcCfg_logCfg = - (svcCfg_logCfg cfg) { logCfg_level = newLogLevel } }) - mapOpt (Option a b arg d) = Option a b (mapArg arg) d - mapArg (NoArg a) = NoArg (lift a) - mapArg (ReqArg f x) = ReqArg (\s -> lift (f s)) x - mapArg (OptArg f x) = OptArg (\ms -> lift (f ms)) x + -- Enable this to cause a crash + seq mcfg (return ()) + hPutStrLn stderr $ "Evaluated1" + seq (mcfg >>= parseCfg id) (return ()) + hPutStrLn stderr $ "Evaluated2" + return undefined Index: DociGateway/src/MobileGateway/Util/ConfigMain.hs =================================================================== --- DociGateway.orig/src/MobileGateway/Util/ConfigMain.hs 2010-09-22 11:05:26.000000000 +0200 +++ DociGateway/src/MobileGateway/Util/ConfigMain.hs 2010-09-22 11:09:28.000000000 +0200 @@ -1,9 +1,11 @@ import System.Environment (getArgs) import MobileGateway.Util.Config +import System.IO main = - do (cfg, [mgwCfg]) <- getConfigWithSections getDataFileName ["SalviaDerivationServer"] + do hPutStrLn stderr $ "Before" + (cfg, [mgwCfg]) <- getConfigWithSections getDataFileName ["SalviaDerivationServer"] putStrLn "ok" return () where getDataFileName name = return $ "./" ++ name Index: DociGateway/src/MobileGateway/Util/Misc.hs =================================================================== --- DociGateway.orig/src/MobileGateway/Util/Misc.hs 2010-09-22 11:05:26.000000000 +0200 +++ DociGateway/src/MobileGateway/Util/Misc.hs 2010-09-22 11:18:09.000000000 +0200 @@ -3,8 +3,7 @@ module MobileGateway.Util.Misc ( eitherToError, errorToEither, liftError, errorToDefault, errorToMaybe, maybeToError , integralToHexString - , readM, unzipF , readProcessWithExitCode - , runFastCgiServer + , readM ) where @@ -21,6 +20,7 @@ import Control.Monad.Error (MonadError, Error, runErrorT, throwError, catchError) import Control.Monad.Identity (runIdentity) +-- Uncomment this to prevent the crash import Data.Foldable as F import Data.Char (toUpper) @@ -36,12 +36,11 @@ -- SITE-PACKAGES ---------------------------------------- -import Network.FastCGI (runFastCGIConcurrent') - +-- Uncomment any of these three to prevent the crash import qualified Data.ByteString.Lazy as BSL import qualified Test.QuickCheck as QC -import Factis.Haskoon.WebCGI (runWebCGIResult) +import Factis.Haskoon.WebCGI () eitherToError :: MonadError e m => Either e a -> m a eitherToError resOrErr = @@ -73,47 +72,6 @@ (x:_) -> return x res -> fail $ "Misc.readM: parse of " ++ show s ++ " returned: " ++ show res -unzipF :: (Alternative k, Alternative l, Foldable t) => t (a, b) -> (k a, l b) -unzipF = F.foldr (\(a,b) (as,bs) -> (pure a <|> as, pure b <|> bs)) (empty,empty) - -readProcessWithExitCode :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> BSL.ByteString -- ^ standard input - -> IO (ExitCode, BSL.ByteString, String) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - - hSetBinaryMode inh True - hSetBinaryMode outh True - - outMVar <- newEmptyMVar - - -- fork off a thread to start consuming stdout - out <- BSL.hGetContents outh - _ <- forkIO $ C.evaluate (BSL.length out) >> putMVar outMVar () - - -- fork off a thread to start consuming stderr - err <- hGetContents errh - _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () - - -- now write and flush any input - when (not (BSL.null input)) $ do BSL.hPutStr inh input - hFlush inh - hClose inh -- done with stdin - - -- wait on the output - takeMVar outMVar - takeMVar outMVar - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess pid - - return (ex, out, err) integralToHexString :: Integral a => a -> String integralToHexString i @@ -142,12 +100,3 @@ 14 -> 'e' 15 -> 'f' _ -> error "integralToHexString: cannot happen" - -prop_integralToHexStringOk :: Int -> Bool -prop_integralToHexStringOk i' = - let i = abs i' - in i == read ("0x" ++ integralToHexString i) - -runFastCgiServer webReq = - do let cgi = runWebCGIResult webReq - runFastCGIConcurrent' forkIO 10 cgi Index: DociGateway/test.sh =================================================================== --- DociGateway.orig/test.sh 2010-09-22 11:05:26.000000000 +0200 +++ DociGateway/test.sh 2010-09-22 11:05:37.000000000 +0200 @@ -1,5 +1,5 @@ -#!/bin/bash +#!/bin/bash -e echo "Compiling..." -ghc -threaded -O2 -prof -fforce-recomp -auto-all -caf-all -hide-package transformers -hide-package monads-fd --make -isrc src/MobileGateway/Util/ConfigMain.hs +ghc -threaded -O2 -prof -fforce-recomp -auto-all -caf-all -hide-package transformers --make -isrc src/MobileGateway/Util/ConfigMain.hs echo "Running..." src/MobileGateway/Util/ConfigMain