Ticket #4330: 4330-reduce-size.patch

File 4330-reduce-size.patch, 17.9 KB (added by nomeata, 5 years ago)

Attempts to reduce the test case size

  • src/MobileGateway/Util/Config.hs

    old new  
     1{-# LANGUAGE PatternGuards #-} 
     2{-# LANGUAGE Rank2Types #-} 
    13{-# LANGUAGE ScopedTypeVariables #-} 
    24module MobileGateway.Util.Config 
    3     (Cfg(..), ServiceCfg(..), TcpServiceCfg(..), WebServiceCfg(..), LogCfg(..) 
    4     , getUrl, getWebPort, getTcpPort, getConfig, getConfigWithSections, updateSvcCfgWithArgs 
    5     , getReferencedService, defaultLogCfg 
    6 ) where 
     5     where 
    76 
    87---------------------------------------- 
    98-- STDLIB 
    109---------------------------------------- 
    11 import Control.Monad (liftM, mplus) 
     10import Control.Monad (liftM, mplus, when) 
    1211import Control.Monad.Error (MonadError, catchError) 
    1312import Control.Monad.Writer (WriterT, runWriterT, tell) 
    1413import Control.Monad.State (StateT, runStateT, execStateT, modify) 
    1514import Control.Monad.Trans (lift) 
    1615import Control.Monad.Fix (mfix) 
     16import Control.Monad.Error (MonadError, Error, runErrorT, throwError, catchError) 
    1717 
    1818import Data.Char (toUpper) 
    1919import Data.Maybe (fromMaybe) 
     
    2828import qualified System.Environment as Env 
    2929import qualified System.Posix.User as User 
    3030 
     31import Debug.Trace 
     32 
    3133---------------------------------------- 
    3234-- SITE-PACKAGES 
    3335---------------------------------------- 
     
    4244---------------------------------------- 
    4345-- LOCAL 
    4446---------------------------------------- 
    45 import MobileGateway.Util.Misc (errorToMaybe, errorToDefault) 
     47 
     48import MobileGateway.Util.Misc  
    4649 
    4750_DEFAULTS_SECTION_ = "DEFAULTS" 
    4851 
     
    5053--                             , svcCfg_pollIntervalSeconds :: Maybe Int 
    5154-- 
    5255 
     56 
    5357data LogCfg = LogCfg { logCfg_file :: Maybe String 
    5458                     , logCfg_level :: Priority 
    5559                     } 
     
    8387parseConfig :: [String] -> (String -> String) -> Cfg.ConfigParser 
    8488            -> Either Cfg.CPError (Cfg, [ServiceCfg]) 
    8589parseConfig serviceNames repl cp = 
    86     do prot <- liftM repl $ errorToDefault "http" $ Cfg.get cp "DEFAULTS" "web-protocol" 
    87        host <- liftM repl $ errorToDefault "localhost" $ Cfg.get cp "DEFAULTS" "web-host" 
    88        mport <- errorToMaybe $ Cfg.get cp "DEFAULTS" "web-port" 
    89        port <- 
    90            case mport of 
    91              Just portstr -> parsePort portstr 
    92              Nothing -> return 80 
    93        prefix <- liftM repl $ errorToDefault "" $ Cfg.get cp "DEFAULTS" "web-prefix" 
    94        let defaults = (prot,host,port,prefix) 
     90    do prot <- return undefined 
     91       host <- return undefined 
     92       port <- return undefined 
     93       prefix <- return undefined 
     94       let defaults = undefined 
    9595           serviceSects = filter (/=_DEFAULTS_SECTION_) (Cfg.sections cp) 
     96       -- No crash if hard-wiring the results: 
     97       -- let serviceSects = ["DerivationGateway","FastCgiDataServer","FastCgiDerivationServer","LubSyncClient","Mantis","MobileGateway","SalviaDataServer","SalviaDerivationGateway","SalviaDerivationServer","VDataServer"] 
    9698       serviceMap <- mfix $ 
    9799                     \serviceMap -> 
    98100                         do services <- mapM (parseServiceCfg serviceMap) serviceSects 
    99101                            return (zip serviceSects services) 
    100102       services <- mapM (getService serviceMap) serviceNames 
    101        return (Cfg serviceMap defaults, services) 
     103       return undefined 
    102104    where 
    103105      consume section name = Cfg.get cp section name >>= \x -> tell [name] >> return x 
    104106      parseServiceCfg :: [(String, ServiceCfg)] -> String -> Either Cfg.CPError ServiceCfg 
    105107      parseServiceCfg serviceMap section = 
    106108          do let parsePredefined = 
    107                      do webSvc <- parseWebCfg section 
     109                     do -- Removing any of the following lines prevents a crash 
     110                        webSvc <- return undefined 
    108111                        tcpSvc <- parseTcpCfg section 
    109112                        logCfg <- parseLogCfg section 
    110                         --pollinterval <- errorToMaybe (Cfg.get cp section "pollinterval") 
    111                         --                               >>= parsePollInterval 
    112                         return (ServiceCfg section logCfg webSvc tcpSvc) 
     113                        return undefined 
    113114             (mkServiceCfg, usedItems) <- runWriterT parsePredefined 
    114115             allItems <- Cfg.items cp section 
    115116             let svcPrefix = "Service-" 
     
    127128             let upd x = x { logCfg_file = logfile `mplus` logCfg_file x 
    128129                           , logCfg_level = fromMaybe (logCfg_level x) loglevel 
    129130                           } 
     131             -- This prevents a crash: 
     132             -- let upd x = x 
    130133             return (upd defaultLogCfg) 
    131       parseTcpCfg section = 
     134      parseTcpCfg section = if False then return undefined else 
     135          -- Commenting out this prevents a crash 
    132136          do host <- liftM (fromMaybe "localhost") $ errorToMaybe (consume section "tcp-host") 
    133              mportstr <- errorToMaybe $ consume section "tcp-port" 
     137             (mportstr :: Maybe String) <- errorToMaybe $ consume section "tcp-port" 
    134138             case mportstr of 
    135139               Just portstr -> 
    136140                   do port <- parsePort portstr 
    137141                      return (Just $ TcpServiceCfg port host) 
    138142               Nothing -> return Nothing 
    139       parseWebCfg section = 
    140           do mprot <- errorToMaybe (liftM repl $ consume section "web-protocol") 
    141              mhost <- errorToMaybe (liftM repl $ consume section "web-host") 
    142              mport' <- errorToMaybe (liftM repl $ consume section "web-port") 
    143              mport <- 
    144                  case mport' of 
    145                    Nothing -> return Nothing 
    146                    Just portstr -> liftM Just $ parsePort portstr 
    147              mprefix <- errorToMaybe (liftM repl $ consume section "web-prefix") 
    148              mpath <- errorToMaybe $ consume section "web-path" 
    149              case mpath of 
    150                Just path -> return (Just $ WebServiceCfg mprot mhost mport mprefix path) 
    151                Nothing -> return Nothing 
    152       parsePort :: Monad m => String -> m Int 
    153       parsePort portstr = 
    154           case readMay portstr of 
    155             Just port -> return port 
    156             Nothing -> fail $ "Not a valid port number: " ++ portstr 
    157143      parsePollInterval Nothing = return Nothing 
    158144      parsePollInterval (Just s) = 
    159145          case readMay s of 
     
    164150            Just svc -> return svc 
    165151            Nothing -> fail ("Service `" ++ svcName ++ "' needed but not defined anywhere.") 
    166152 
     153parsePort :: Monad m => String -> m Int 
     154parsePort portstr = do 
     155  -- Tracing the portstr prevents the crash 
     156  -- trace portstr (return ()) 
     157  case readMay portstr of 
     158    Just port -> return port 
     159    Nothing -> fail $ "Not a valid port number: " ++ portstr 
     160 
    167161parseLogLevel :: Monad m => String -> m Priority 
    168 parseLogLevel level = 
    169     case (map toUpper) level of 
    170       "TRACE" -> return DEBUG 
    171       "DEBUG" -> return INFO 
    172       "INFO" -> return NOTICE 
    173       "WARN" -> return WARNING 
    174       "WARNING" -> return WARNING 
    175       "ERROR" -> return ERROR 
    176       _ -> fail $ "Failed to parse log-level `" ++ level ++ "'!" 
     162parseLogLevel level = return undefined 
    177163 
    178164getConfig getDataFileName = 
    179165    do (cfg, []) <- getConfigWithSections getDataFileName [] 
    180166       return cfg 
    181167 
    182 getConfigWithSections getDataFileName sections = 
     168getConfigWithSections getDataFileName sections = do 
    183169    readConfig getDataFileName "MobileGateway.ini" (parseConfig sections) 
    184170 
    185 getUrl :: Cfg -> ServiceCfg -> String 
    186 getUrl (Cfg { cfg_defaults = (defProt, defHost, defPort, defPrefix)}) 
    187        svcCfg@(ServiceCfg 
    188         { svcCfg_webCfg = 
    189               Just (WebServiceCfg { wsCfg_prot = mprot, wsCfg_host = mhost 
    190                                   , wsCfg_prefix = mprefix, wsCfg_path = path 
    191                                   , wsCfg_port = mport })}) 
    192            = let prot = fromMaybe defProt mprot 
    193                  host = fromMaybe defHost mhost 
    194                  prefix = fromMaybe defPrefix mprefix 
    195                  port = fromMaybe defPort mport 
    196                  portstr = if port == 80 then "" else ':' : show port 
    197              in prot ++ "://" ++ (host ++ portstr </> prefix </> path) 
    198 getUrl _ _ = error "Configuration doesn't include web service configuration." 
    199  
    200 getWebPort :: ServiceCfg -> Maybe Int 
    201 getWebPort svcCfg = 
    202     do webCfg <- svcCfg_webCfg svcCfg 
    203        wsCfg_port webCfg 
    204  
    205 getTcpPort :: ServiceCfg -> Maybe Int 
    206 getTcpPort svcCfg = 
    207     do tcpCfg <- svcCfg_tcpCfg svcCfg 
    208        return $ tcpCfg_port tcpCfg 
    209171 
    210172-- == GENERAL FUNCTION ======================================================== 
    211  
    212 getHomeDir :: IO FilePath 
    213 getHomeDir = 
    214     do uid <- User.getEffectiveUserID 
    215        liftM User.homeDirectory (User.getUserEntryForID uid) 
    216  
    217 getUser :: IO String 
    218 getUser = 
    219     do uid <- User.getEffectiveUserID 
    220        liftM User.userName (User.getUserEntryForID uid) 
    221  
    222  
    223 findConfig :: (String -> IO String) -> String -> IO FilePath 
    224 findConfig getDataFileName confName = 
    225     do progDir <- liftM takeDirectory Env.getProgName >>= Dir.canonicalizePath 
    226        homeDir <- getHomeDir 
    227        curDir <- Dir.getCurrentDirectory >>= Dir.canonicalizePath 
    228        defaultLoc <- getDataFileName confName 
    229        let locs = [dir </> confName | dir <- [curDir, progDir, homeDir]] ++ [defaultLoc] 
    230            find [] = fail ("No configuration file found. The following " 
    231                            ++ "locations were searched: " 
    232                            ++ concat (intersperse ", " locs)) 
    233            find (x:xs) = do ex <- Dir.doesFileExist x 
    234                             if ex then return x else find xs 
    235        find locs 
    236  
     173readConfig :: (String -> IO String) -> String -> ((String -> String) -> Cfg.ConfigParser -> Either Cfg.CPError (Cfg, [ServiceCfg])) -> IO (Cfg,[ServiceCfg]) 
    237174readConfig getDataFileName confName parseCfg = 
    238     do cfgFile <- findConfig getDataFileName confName 
    239        repls <- getReplacements 
     175    do curDir <- Dir.getCurrentDirectory >>= Dir.canonicalizePath 
     176       -- cfgFile <- findConfig getDataFileName confName 
     177       let cfgFile =  "./MobileGateway.ini" 
     178       let cfgFile = curDir </> "MobileGateway.ini" 
    240179       hPutStrLn stderr $ "Reading config file `"++cfgFile++"'..." 
    241180       mcfg <- Cfg.readfile Cfg.emptyCP cfgFile 
    242        let showErr ty arg src = fail ("Error parsing config file `" ++ cfgFile 
    243                                       ++ "' at " ++ src ++ ":\n" 
    244                                       ++ ty ++ ": " ++ arg) 
    245        case mcfg >>= parseCfg (applyRepls repls) of 
    246          Left (Cfg.ParseError msg, src) -> showErr "ParseError" msg src 
    247          Left (Cfg.NoSection sec, src) -> showErr "NoSection" sec src 
    248          Left (Cfg.NoOption opt, src) -> showErr "NoOption" opt src 
    249          Left (Cfg.SectionAlreadyExists msg, src) -> 
    250              showErr "DuplicateSection" msg src 
    251          Left (Cfg.OtherProblem msg, src) -> showErr "Error" msg src 
    252          Left (Cfg.InterpolationError msg, src) -> showErr "Error" msg src 
    253          Right cfg -> 
    254              do hPutStrLn stderr $ "Got configuration." 
    255                 return cfg 
    256     where 
    257       applyRepls (home,user) = replace "$HOME" home . replace "$USER" user 
    258       getReplacements = 
    259           do home <- getHomeDir 
    260              user <- getUser 
    261              return (home,user) 
    262  
    263 getReferencedService :: ServiceCfg -> String -> IO ServiceCfg 
    264 getReferencedService sect@(ServiceCfg { svcCfg_services = serviceMap }) svcName = 
    265     case lookup svcName serviceMap of 
    266       Just svc -> return svc 
    267       Nothing -> fail ("Service `" ++ svcCfg_name sect ++ 
    268                        "' doesn't have a service reference to `" ++ svcName ++ "'.") 
    269  
    270 updateSvcCfgWithArgs :: forall s. 
    271                         [OptDescr (StateT s IO ())] 
    272                      -> s 
    273                      -> ServiceCfg 
    274                      -> [String] 
    275                      -> IO (s, ServiceCfg, [String]) 
    276 updateSvcCfgWithArgs moreOpts s svcCfg args = 
    277     do progName <- Env.getProgName 
    278        case getOpt RequireOrder options args of 
    279          (actions, nonOpts, []) -> 
    280              do (svcCfg', s') <- runStateT (execStateT (sequence_ actions) svcCfg) s 
    281                 return (s', svcCfg', nonOpts) 
    282          (_, _, msgs) -> error $ concat msgs ++ usageInfo (header progName) options 
    283     where 
    284       options :: [OptDescr (StateT ServiceCfg (StateT s IO) ())] 
    285       options = 
    286           [ (Option [] ["log-level"] (ReqArg setLogLevel "LOGLEVEL") 
    287              "override log-level from config file") 
    288           ] ++ map mapOpt moreOpts 
    289       header progName = "Usage: " ++ progName ++ " [OPTION...]" 
    290       setLogLevel  newLevelStr = 
    291           do newLogLevel <- parseLogLevel newLevelStr 
    292              modify (\cfg -> 
    293                          cfg { svcCfg_logCfg = 
    294                                    (svcCfg_logCfg cfg) { logCfg_level = newLogLevel } }) 
    295       mapOpt (Option a b arg d) = Option a b (mapArg arg) d 
    296       mapArg (NoArg a) = NoArg (lift a) 
    297       mapArg (ReqArg f x) = ReqArg (\s -> lift (f s)) x 
    298       mapArg (OptArg f x) = OptArg (\ms -> lift (f ms)) x 
     181       -- Enable this to cause a crash 
     182       seq mcfg (return ()) 
     183       hPutStrLn stderr $ "Evaluated1" 
     184       seq (mcfg >>= parseCfg id) (return ()) 
     185       hPutStrLn stderr $ "Evaluated2" 
     186       return undefined 
  • src/MobileGateway/Util/ConfigMain.hs

    old new  
    11import System.Environment (getArgs) 
    22 
    33import MobileGateway.Util.Config 
     4import System.IO 
    45 
    56main = 
    6     do (cfg, [mgwCfg]) <- getConfigWithSections getDataFileName ["SalviaDerivationServer"] 
     7    do hPutStrLn stderr $ "Before" 
     8       (cfg, [mgwCfg]) <- getConfigWithSections getDataFileName ["SalviaDerivationServer"] 
    79       putStrLn "ok" 
    810       return () 
    911    where getDataFileName name = return $ "./" ++ name 
  • src/MobileGateway/Util/Misc.hs

    old new  
    33module MobileGateway.Util.Misc 
    44    ( eitherToError, errorToEither, liftError, errorToDefault, errorToMaybe, maybeToError 
    55    , integralToHexString 
    6     , readM, unzipF , readProcessWithExitCode 
    7     , runFastCgiServer 
     6    , readM 
    87    ) 
    98where 
    109 
     
    2120import Control.Monad.Error (MonadError, Error, runErrorT, throwError, catchError) 
    2221import Control.Monad.Identity (runIdentity) 
    2322 
     23-- Uncomment this to prevent the crash 
    2424import Data.Foldable as F 
    2525import Data.Char (toUpper) 
    2626 
     
    3636-- SITE-PACKAGES 
    3737---------------------------------------- 
    3838 
    39 import Network.FastCGI (runFastCGIConcurrent') 
    40  
     39-- Uncomment any of these three to prevent the crash 
    4140import qualified Data.ByteString.Lazy as BSL 
    4241import qualified Test.QuickCheck as QC 
    4342 
    44 import Factis.Haskoon.WebCGI (runWebCGIResult) 
     43import Factis.Haskoon.WebCGI () 
    4544 
    4645eitherToError :: MonadError e m => Either e a -> m a 
    4746eitherToError resOrErr = 
     
    7372      (x:_) -> return x 
    7473      res -> fail  $ "Misc.readM: parse of " ++ show s ++ " returned: " ++ show res 
    7574 
    76 unzipF :: (Alternative k, Alternative l, Foldable t) => t (a, b) -> (k a, l b) 
    77 unzipF = F.foldr (\(a,b) (as,bs) -> (pure a <|> as,  pure b <|> bs)) (empty,empty) 
    78  
    79 readProcessWithExitCode :: FilePath                                      -- ^ command to run 
    80                         -> [String]                                      -- ^ any arguments 
    81                         -> BSL.ByteString                                -- ^ standard input 
    82                         -> IO (ExitCode, BSL.ByteString, String) -- ^ exitcode, stdout, stderr 
    83 readProcessWithExitCode cmd args input = do 
    84     (Just inh, Just outh, Just errh, pid) <- 
    85         createProcess (proc cmd args){ std_in  = CreatePipe, 
    86                                        std_out = CreatePipe, 
    87                                        std_err = CreatePipe } 
    88  
    89     hSetBinaryMode inh True 
    90     hSetBinaryMode outh True 
    91  
    92     outMVar <- newEmptyMVar 
    93  
    94     -- fork off a thread to start consuming stdout 
    95     out  <- BSL.hGetContents outh 
    96     _ <- forkIO $ C.evaluate (BSL.length out) >> putMVar outMVar () 
    97  
    98     -- fork off a thread to start consuming stderr 
    99     err  <- hGetContents errh 
    100     _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () 
    101  
    102     -- now write and flush any input 
    103     when (not (BSL.null input)) $ do BSL.hPutStr inh input 
    104                                      hFlush inh 
    105     hClose inh -- done with stdin 
    106  
    107     -- wait on the output 
    108     takeMVar outMVar 
    109     takeMVar outMVar 
    110     hClose outh 
    111     hClose errh 
    112  
    113     -- wait on the process 
    114     ex <- waitForProcess pid 
    115  
    116     return (ex, out, err) 
    11775 
    11876integralToHexString :: Integral a => a -> String 
    11977integralToHexString i 
     
    142100                           14 -> 'e' 
    143101                           15 -> 'f' 
    144102                           _ -> error "integralToHexString: cannot happen" 
    145  
    146 prop_integralToHexStringOk :: Int -> Bool 
    147 prop_integralToHexStringOk i' = 
    148     let i = abs i' 
    149     in i == read ("0x" ++ integralToHexString i) 
    150  
    151 runFastCgiServer webReq = 
    152    do let cgi = runWebCGIResult  webReq 
    153       runFastCGIConcurrent' forkIO 10 cgi 
  • DociGateway

    old new  
    1 #!/bin/bash 
     1#!/bin/bash -e 
    22echo "Compiling..." 
    3 ghc -threaded -O2 -prof -fforce-recomp -auto-all -caf-all -hide-package transformers -hide-package monads-fd --make -isrc src/MobileGateway/Util/ConfigMain.hs 
     3ghc -threaded -O2 -prof -fforce-recomp -auto-all -caf-all -hide-package transformers --make -isrc src/MobileGateway/Util/ConfigMain.hs 
    44echo "Running..." 
    55src/MobileGateway/Util/ConfigMain