darcsweb - test/Properties/Config.hs

{-# LANGUAGE OverloadedStrings #-}

module Properties.Config (tests) where

import Test.QuickCheck

import DarcsWeb.Config (parsePortPure)

-- --------------------------------------------------------------------------
-- parsePortPure: pin the accepted/rejected port-value set so a future
-- refactor of the startup parser cannot silently widen or narrow it.
-- --------------------------------------------------------------------------

prop_port_accepts_valid :: Property
prop_port_accepts_valid =
    forAll (choose (1, 65535)) $ \p ->
      parsePortPure (show p) == Just (p :: Int)

prop_port_rejects_zero :: Bool
prop_port_rejects_zero = parsePortPure "0" == Nothing

prop_port_rejects_negative :: Property
prop_port_rejects_negative =
    forAll (choose (minBound :: Int, -1)) $ \p ->
      parsePortPure (show p) == Nothing

prop_port_rejects_over_max :: Property
prop_port_rejects_over_max =
    forAll (choose (65536, maxBound :: Int)) $ \p ->
      parsePortPure (show p) == Nothing

prop_port_rejects_non_numeric :: Bool
prop_port_rejects_non_numeric = and
    [ parsePortPure ""       == Nothing
    , parsePortPure "   "    == Nothing
    , parsePortPure "abc"    == Nothing
    , parsePortPure "80a"    == Nothing
    , parsePortPure "8080 "  == Nothing  -- trailing space
    , parsePortPure " 8080"  == Nothing  -- leading space
    , parsePortPure "8080#"  == Nothing  -- trailing comment
    , parsePortPure "0x50"   == Nothing  -- hex not accepted
    ]

-- --------------------------------------------------------------------------
-- Test runner
-- --------------------------------------------------------------------------

tests :: IO Bool
tests = fmap and $ sequence
    [ run "port accepts 1..65535"     (property prop_port_accepts_valid)
    , run "port rejects 0"            (property prop_port_rejects_zero)
    , run "port rejects negative"     (property prop_port_rejects_negative)
    , run "port rejects over-max"     (property prop_port_rejects_over_max)
    , run "port rejects non-numeric"  (property prop_port_rejects_non_numeric)
    ]
  where
    run name prop = do
      putStr $ "  " ++ name ++ ": "
      r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
      return (isSuccess r)