Merge pull request #38 from aviaviavi/skip-tls-check

skip-tls-check option
aviaviavi · Mar 15, 2019 · f9561c4 · f9561c4
2 parents 9fa5f26 + b802d67
commit f9561c4
Show file tree

Hide file tree

Showing 6 changed files with 56 additions and 35 deletions.
diff --git a/app/Main.hs b/app/Main.hs
@@ -30,9 +30,10 @@ import           Testing.CurlRunnings.Types
 
 -- | Command line flags
 data CurlRunnings = CurlRunnings
-  { file    :: FilePath
-  , grep    :: Maybe T.Text
-  , upgrade :: Bool
+  { file           :: FilePath
+  , grep           :: Maybe T.Text
+  , upgrade        :: Bool
+  , skip_tls_check :: Bool
   } deriving (Show, Data, Typeable, Eq)
 
 -- | cmdargs object
@@ -42,6 +43,7 @@ argParser =
   { file = def &= typFile &= help "File to run"
   , grep = def &= help "Regex to filter test cases by name"
   , upgrade = def &= help "Pull the latest version of curl runnings"
+  , skip_tls_check = def &= help "Don't perform a TLS check (USE WITH CAUTION. Only use this if you signed your own certs)"
   } &=
   summary ("curl-runnings " ++ showVersion version) &=
   program "curl-runnings" &=
@@ -72,17 +74,17 @@ instance FromJSON GithubReleasesResponse
 setGithubReqHeaders :: Request -> Request
 setGithubReqHeaders = setRequestHeaders [("User-Agent", "aviaviavi")]
 
-runFile :: FilePath -> Verbosity -> Maybe T.Text -> IO ()
-runFile "" _ _ =
+runFile :: FilePath -> Verbosity -> Maybe T.Text -> TLSCheckType -> IO ()
+runFile "" _ _ _ =
   putStrLn
     "Please specify an input file with the --file (-f) flag or use --help for more information"
-runFile path verbosityLevel regexp = do
+runFile path verbosityLevel regexp tlsType = do
   home <- getEnv "HOME"
   suite <- decodeFile . T.unpack $ T.replace "~" (T.pack home) (T.pack path)
   case suite of
     Right s -> do
       results <-
-        runSuite (s {suiteCaseFilter = regexp}) $ toLogLevel verbosityLevel
+        runSuite (s {suiteCaseFilter = regexp}) (toLogLevel verbosityLevel) $ tlsType
       if any isFailing results
         then putStrLn (T.unpack $ makeRed "Some tests failed") >>
              exitWith (ExitFailure 1)
@@ -188,6 +190,7 @@ main :: IO ()
 main = do
   userArgs <- cmdArgs argParser
   verbosityLevel <- getVerbosity
+  let tlsCheckType = if skip_tls_check userArgs then SkipTLSCheck else DoTLSCheck
   if upgrade userArgs
     then upgradeCurlRunnings
-    else runFile (file userArgs) verbosityLevel (grep userArgs)
+    else runFile (file userArgs) verbosityLevel (grep userArgs) tlsCheckType
diff --git a/curl-runnings.cabal b/curl-runnings.cabal
@@ -1,8 +1,10 @@
--- This file has been generated from package.yaml by hpack version 0.28.2.
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0e66b58842dd3cfc4bba11992201740113a8539e45270702205df083d4feb579
+-- hash: 189771adeec42ac2e6e8c4262b0b81286359f74f9b96f05112a73a634b960615
 
 name:           curl-runnings
 version:        0.9.2
@@ -17,13 +19,12 @@ copyright:      2018 Avi Press
 license:        MIT
 license-file:   LICENSE
 build-type:     Simple
-cabal-version:  >= 1.10
 extra-source-files:
+    README.md
     examples/example-spec.json
     examples/example-spec.yaml
     examples/importable.yaml
     examples/interpolation-spec.yaml
-    README.md
 
 source-repository head
   type: git
@@ -34,12 +35,14 @@ library
       src
   build-depends:
       aeson >=1.2.4.0
-    , base >=4.7 && <5
+    , base >=4.0 && <5
     , bytestring >=0.10.8.2
     , case-insensitive >=0.2.1
+    , connection >=0.2.8
     , directory >=1.3.0.2
     , hspec >=2.4.4
     , hspec-expectations >=0.8.2
+    , http-client-tls >=0.3.5.3
     , http-conduit >=2.2.4
     , http-types >=0.9.1
     , megaparsec >=6.3.0
@@ -85,7 +88,7 @@ test-suite curl-runnings-test
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      base >=4.0 && <5
     , curl-runnings
     , directory >=1.3.0.2
     , hspec >=2.4.4

diff --git a/package.yaml b/package.yaml
@@ -12,17 +12,10 @@ extra-source-files:
 - README.md
 - examples/*
 
-# Metadata used when publishing your package
-# synopsis:            Short description of your package
-# category:            Web
-
-# To avoid duplicated efforts in documentation and dealing with the
-# complications of embedding Haddock markup inside cabal files, it is
-# common to point users to the README.md file.
 description:         Please see the README on Github at <https://github.com/aviaviavi/curl-runnings#readme>
 
 dependencies:
-- base >= 4.7 && < 5
+- base >= 4.0 && < 5
 
 library:
   source-dirs: src
@@ -41,6 +34,8 @@ library:
   - http-conduit >=2.2.4
   - http-types >=0.9.1
   - megaparsec >=6.3.0
+  - connection >=0.2.8
+  - http-client-tls >=0.3.5.3
   - pretty-simple >=2.0.2.1
   - regex-posix >=0.95.2
   - text >=1.2.2.2

diff --git a/src/Testing/CurlRunnings.hs b/src/Testing/CurlRunnings.hs
@@ -24,6 +24,8 @@ import           Data.Monoid
 import qualified Data.Text                            as T
 import qualified Data.Vector                          as V
 import qualified Data.Yaml.Include                    as YI
+import           Network.Connection                   (TLSSettings (..))
+import           Network.HTTP.Client.TLS              (mkManagerSettings)
 import           Network.HTTP.Conduit
 import           Network.HTTP.Simple
 import qualified Network.HTTP.Types.Header            as HTTP
@@ -35,6 +37,7 @@ import           Testing.CurlRunnings.Types
 import           Text.Printf
 import           Text.Regex.Posix
 
+
 -- | decode a json or yaml file into a suite object
 decodeFile :: FilePath -> IO (Either String CurlSuite)
 decodeFile specPath =
@@ -48,10 +51,22 @@ decodeFile specPath =
              _ -> return . Left $ printf "Invalid spec path %s" specPath
       else return . Left $ printf "%s not found" specPath
 
+
+noVerifyTlsManagerSettings :: ManagerSettings
+noVerifyTlsManagerSettings = mkManagerSettings noVerifyTlsSettings Nothing
+
+noVerifyTlsSettings :: TLSSettings
+noVerifyTlsSettings =
+  TLSSettingsSimple
+  { settingDisableCertificateValidation = True
+  , settingDisableSession = True
+  , settingUseServerName = False
+  }
+
 -- | Run a single test case, and returns the result. IO is needed here since this method is responsible
 -- for actually curling the test case endpoint and parsing the result.
 runCase :: CurlRunningsState -> CurlCase -> IO CaseResult
-runCase state curlCase = do
+runCase state@(CurlRunningsState _ _ _ tlsCheckType) curlCase = do
   let eInterpolatedUrl = interpolateQueryString state $ url curlCase
       eInterpolatedHeaders =
         interpolateHeaders state $ fromMaybe (HeaderSet []) (headers curlCase)
@@ -66,9 +81,11 @@ runCase state curlCase = do
           return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase l]
         Right replacedJSON -> do
           initReq <- parseRequest $ T.unpack interpolatedUrl
+          manager <- newManager noVerifyTlsManagerSettings
           let request =
                 setRequestBodyJSON (fromMaybe emptyObject replacedJSON) .
-                setRequestHeaders (toHTTPHeaders interpolatedHeaders) $
+                setRequestHeaders (toHTTPHeaders interpolatedHeaders) .
+                (if tlsCheckType == DoTLSCheck then id else (setRequestManager manager)) $
                 initReq {method = B8S.pack . show $ requestMethod curlCase}
           logger state DEBUG (pShow request)
           logger
@@ -183,8 +200,8 @@ printR :: Show a => a -> IO a
 printR x = print x >> return x
 
 -- | Runs the test cases in order and stop when an error is hit. Returns all the results
-runSuite :: CurlSuite -> LogLevel -> IO [CaseResult]
-runSuite (CurlSuite cases filterRegex) logLevel = do
+runSuite :: CurlSuite -> LogLevel -> TLSCheckType -> IO [CaseResult]
+runSuite (CurlSuite cases filterRegex) logLevel tlsType = do
   fullEnv <- getEnvironment
   let envMap = H.fromList $ map (\(x, y) -> (T.pack x, T.pack y)) fullEnv
       filterNameByRegexp curlCase =
@@ -198,12 +215,12 @@ runSuite (CurlSuite cases filterRegex) logLevel = do
          Just CaseFail {} -> return prevResults
          Just CasePass {} -> do
            result <-
-             runCase (CurlRunningsState envMap prevResults logLevel) curlCase >>=
+             runCase (CurlRunningsState envMap prevResults logLevel tlsType) curlCase >>=
              printR
            return $ prevResults ++ [result]
          Nothing -> do
            result <-
-             runCase (CurlRunningsState envMap [] logLevel) curlCase >>= printR
+             runCase (CurlRunningsState envMap [] logLevel tlsType) curlCase >>= printR
            return [result])
     []
     (filter filterNameByRegexp cases)
@@ -367,14 +384,14 @@ getStringValueForQuery state i@(InterpolatedQuery rawText (Query _)) =
     Left l           -> Left l
     Right (String s) -> Right $ rawText <> s
     (Right o)        -> Left $ QueryTypeMismatch "Expected a string" o
-getStringValueForQuery (CurlRunningsState env _ _) (InterpolatedQuery rawText (EnvironmentVariable v)) =
+getStringValueForQuery (CurlRunningsState env _ _ _) (InterpolatedQuery rawText (EnvironmentVariable v)) =
   Right $ rawText <> H.lookupDefault "" v env
 
 -- | Lookup the value for the specified query
 getValueForQuery ::
      CurlRunningsState -> InterpolatedQuery -> Either QueryError Value
 getValueForQuery _ (LiteralText rawText) = Right $ String rawText
-getValueForQuery (CurlRunningsState _ previousResults _) full@(NonInterpolatedQuery (Query indexes)) =
+getValueForQuery (CurlRunningsState _ previousResults _ _) full@(NonInterpolatedQuery (Query indexes)) =
   case head indexes of
     (CaseResultIndex i) ->
       let maybeCase = arrayGet previousResults $ fromInteger i
@@ -417,7 +434,7 @@ getValueForQuery (CurlRunningsState _ previousResults _) full@(NonInterpolatedQu
       T.pack $
       "'$< ... >' queries must start with a RESPONSES[index] query: " ++
       show full
-getValueForQuery (CurlRunningsState env _ _) (NonInterpolatedQuery (EnvironmentVariable var)) =
+getValueForQuery (CurlRunningsState env _ _ _) (NonInterpolatedQuery (EnvironmentVariable var)) =
   Right . String $ H.lookupDefault "" var env
 getValueForQuery state (InterpolatedQuery _ q) =
   case getValueForQuery state (NonInterpolatedQuery q) of

diff --git a/src/Testing/CurlRunnings/Types.hs b/src/Testing/CurlRunnings/Types.hs
@@ -23,6 +23,7 @@ module Testing.CurlRunnings.Types
   , FullQueryText
   , SingleQueryText
   , CurlRunningsState(..)
+  , TLSCheckType(..)
 
   , isFailing
   , isPassing
@@ -391,14 +392,16 @@ isFailing = not . isPassing
 -- | A map of the system environment
 type Environment = H.HashMap T.Text T.Text
 
+data TLSCheckType = SkipTLSCheck | DoTLSCheck deriving (Show, Eq)
+
 -- | The state of a suite. Tracks environment variables, and all the test results so far
-data CurlRunningsState = CurlRunningsState Environment [CaseResult] LogLevel
+data CurlRunningsState = CurlRunningsState Environment [CaseResult] LogLevel TLSCheckType
 
 logger :: CurlRunningsState -> CurlRunningsLogger
-logger (CurlRunningsState _ _ l) = makeLogger l
+logger (CurlRunningsState _ _ l _) = makeLogger l
 
 unsafeLogger :: Show a => CurlRunningsState -> CurlRunningsUnsafeLogger a
-unsafeLogger (CurlRunningsState _ _ l) = makeUnsafeLogger l
+unsafeLogger (CurlRunningsState _ _ l _) = makeUnsafeLogger l
 
 -- | A single lookup operation in a json query
 data Index

diff --git a/stack.yaml b/stack.yaml
@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-10.8
+resolver: lts-12.14
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.