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