Skip to content

Commit 0ae4590

Browse files
kozakkozak
authored
Merge pull request #8 from restaumatic/use-json-improve-ux
Improve UX by comparing/storing JSON, show diff between values
2 parents f71c3c6 + 11cf4aa commit 0ae4590

File tree

6 files changed

+425
-285
lines changed

6 files changed

+425
-285
lines changed

‎fourmolu.yaml

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
indentation: 2
2+
comma-style: leading
3+
import-export-style: leading
4+
indent-wheres: true
5+
record-brace-space: true
6+
diff-friendly-import-export: true
7+
respectful: true
8+
haddock-style: multi-line
9+
newlines-between-decls: 1
10+
fixities: []

‎package.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,8 @@ dependencies:
3737
- warp
3838
- wai
3939
- aeson
40+
- aeson-pretty
41+
- aeson-diff
4042
- yaml
4143
- uri-bytestring
4244
- optparse-applicative

‎src/Network/VCR.hs

Lines changed: 107 additions & 88 deletions
Original file line numberDiff line numberDiff line change
@@ -1,107 +1,126 @@
11
{-# LANGUAGE NamedFieldPuns #-}
2-
module Network.VCR
3-
( server
4-
, withServer
5-
) where
62

7-
import Control.Concurrent (forkIO, killThread, threadDelay)
8-
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
9-
takeMVar)
10-
import Control.Exception (SomeException, bracket)
11-
12-
import Control.Monad
13-
import qualified Data.ByteString.Char8 as BS
3+
module Network.VCR (
4+
server,
5+
withServer,
6+
) where
7+
8+
import Control.Concurrent (forkIO, killThread, threadDelay)
9+
import Control.Concurrent.MVar (
10+
MVar,
11+
newEmptyMVar,
12+
putMVar,
13+
takeMVar,
14+
)
15+
import Control.Exception (SomeException, bracket)
16+
17+
import Control.Monad
18+
import qualified Data.ByteString.Char8 as BS
1419
import qualified Data.ByteString.Lazy.Char8 as LBS
15-
import Data.IORef (IORef, newIORef)
16-
import qualified Data.Text as T
17-
import qualified Network.HTTP.Client as HC
18-
import qualified Network.HTTP.Conduit as HC
19-
import qualified Network.HTTP.Proxy as HProxy (Request (..),
20-
Settings (..),
21-
defaultProxySettings,
22-
httpProxyApp)
23-
import qualified Network.HTTP.Types as HT
24-
import qualified Network.Wai as Wai
25-
import qualified Network.Wai.Handler.Warp as Warp
26-
27-
28-
import Control.Applicative ((<**>))
29-
import Network.VCR.Middleware (die, middleware)
30-
import Network.VCR.Types (Cassette, Mode (..), Options (..),
31-
emptyCassette, parseOptions)
32-
import Options.Applicative (execParser, fullDesc, header,
33-
helper, info, progDesc)
34-
import System.Environment (getArgs)
35-
36-
import Data.Yaml (decodeFileEither, encodeFile)
37-
import System.Directory (doesFileExist)
38-
import System.IO (BufferMode (..), hSetBuffering,
39-
stdout)
40-
20+
import Data.IORef (IORef, newIORef)
21+
import qualified Data.Text as T
22+
import qualified Network.HTTP.Client as HC
23+
import qualified Network.HTTP.Conduit as HC
24+
import qualified Network.HTTP.Proxy as HProxy (
25+
Request (..),
26+
Settings (..),
27+
defaultProxySettings,
28+
httpProxyApp,
29+
)
30+
import qualified Network.HTTP.Types as HT
31+
import qualified Network.Wai as Wai
32+
import qualified Network.Wai.Handler.Warp as Warp
33+
34+
import Control.Applicative ((<**>))
35+
import Network.VCR.Middleware (die, middleware)
36+
import Network.VCR.Types (
37+
Cassette,
38+
Mode (..),
39+
Options (..),
40+
emptyCassette,
41+
parseOptions,
42+
)
43+
import Options.Applicative (
44+
execParser,
45+
fullDesc,
46+
header,
47+
helper,
48+
info,
49+
progDesc,
50+
)
51+
import System.Environment (getArgs)
52+
53+
import Data.Yaml (decodeFileEither, encodeFile)
54+
import System.Directory (doesFileExist)
55+
import System.IO (
56+
BufferMode (..),
57+
hSetBuffering,
58+
stdout,
59+
)
4160

4261
server :: IO ()
4362
server = execParser opts >>= run
4463
where
45-
opts = info (parseOptions <**> helper)
46-
( fullDesc
47-
<> progDesc "Run the VCR proxy to replay or record API calls. Runs in replay mode by default."
48-
<> header "VCR Proxy" )
64+
opts =
65+
info
66+
(parseOptions <**> helper)
67+
( fullDesc
68+
<> progDesc "Run the VCR proxy to replay or record API calls. Runs in replay mode by default."
69+
<> header "VCR Proxy"
70+
)
4971

5072
run :: Options -> IO ()
5173
run options = withServer options $ do
52-
forever $ threadDelay 1000000000
53-
74+
forever $ threadDelay 1000000000
5475

5576
withServer :: Options -> IO a -> IO a
56-
withServer options@Options { mode, cassettePath, port } action = do
57-
putStrLn $ "Starting VCR proxy, mode: " <> show mode <> ", cassette file: " <> cassettePath <> ", listening on port: " <> show port
58-
case mode of
59-
Record endpoint -> do
60-
exists <- doesFileExist cassettePath
61-
when (not exists) $ encodeFile cassettePath (emptyCassette $ T.pack endpoint)
62-
_ -> pure ()
63-
cas <- decodeFileEither cassettePath
64-
case cas of
65-
Left err -> die $ "Cassette: " <> cassettePath <> " couldn't be decoded or found! " <> (show err)
66-
Right cassette -> do
67-
cassetteIORef <- newIORef cassette
68-
runInternal options cassetteIORef $ do
69-
putStrLn "VCR proxy started"
70-
action
77+
withServer options@Options{mode, cassettePath, port} action = do
78+
putStrLn $ "Starting VCR proxy, mode: " <> show mode <> ", cassette file: " <> cassettePath <> ", listening on port: " <> show port
79+
case mode of
80+
Record endpoint -> do
81+
exists <- doesFileExist cassettePath
82+
when (not exists) $ encodeFile cassettePath (emptyCassette $ T.pack endpoint)
83+
_ -> pure ()
84+
cas <- decodeFileEither cassettePath
85+
case cas of
86+
Left err -> die $ "Cassette: " <> cassettePath <> " couldn't be decoded or found! " <> (show err)
87+
Right cassette -> do
88+
cassetteIORef <- newIORef cassette
89+
runInternal options cassetteIORef $ do
90+
putStrLn "VCR proxy started"
91+
action
7192

7293
runInternal :: Options -> IORef Cassette -> IO a -> IO a
73-
runInternal Options { mode, cassettePath, port } cassetteIORef action = do
74-
-- Set line buffering, because if we use it from a parent process, pipes are full buffered by default
75-
hSetBuffering stdout LineBuffering
76-
started <- newEmptyMVar
77-
bracket (start started) killThread $ \_ -> do
78-
takeMVar started
79-
action
80-
94+
runInternal Options{mode, cassettePath, port} cassetteIORef action = do
95+
-- Set line buffering, because if we use it from a parent process, pipes are full buffered by default
96+
hSetBuffering stdout LineBuffering
97+
started <- newEmptyMVar
98+
bracket (start started) killThread $ \_ -> do
99+
takeMVar started
100+
action
81101
where
82102
start started = forkIO $ do
83-
mgr <- HC.newManager HC.tlsManagerSettings
84-
Warp.runSettings (warpSettings started proxySettings) $ middleware mode cassetteIORef cassettePath $ HProxy.httpProxyApp proxySettings mgr
85-
proxySettings = HProxy.defaultProxySettings { HProxy.proxyPort = port }
86-
87-
88-
89-
warpSettings
90-
:: MVar () -- ^ MVar to put after starting
91-
-> HProxy.Settings
92-
-> Warp.Settings
93-
warpSettings started pset = Warp.setPort (HProxy.proxyPort pset)
94-
. Warp.setHost (HProxy.proxyHost pset)
95-
. Warp.setTimeout (HProxy.proxyTimeout pset)
96-
. Warp.setOnExceptionResponse defaultExceptionResponse
97-
-- This is needed so we know when we start using the proxy if it is run as a child process
98-
. Warp.setBeforeMainLoop (putMVar started ())
99-
$ Warp.setNoParsePath True Warp.defaultSettings
103+
mgr <- HC.newManager HC.tlsManagerSettings
104+
Warp.runSettings (warpSettings started proxySettings) $ middleware mode cassetteIORef cassettePath $ HProxy.httpProxyApp proxySettings mgr
105+
proxySettings = HProxy.defaultProxySettings{HProxy.proxyPort = port}
106+
107+
warpSettings ::
108+
-- | MVar to put after starting
109+
MVar () ->
110+
HProxy.Settings ->
111+
Warp.Settings
112+
warpSettings started pset =
113+
Warp.setPort (HProxy.proxyPort pset)
114+
. Warp.setHost (HProxy.proxyHost pset)
115+
. Warp.setTimeout (HProxy.proxyTimeout pset)
116+
. Warp.setOnExceptionResponse defaultExceptionResponse
117+
-- This is needed so we know when we start using the proxy if it is run as a child process
118+
. Warp.setBeforeMainLoop (putMVar started ())
119+
$ Warp.setNoParsePath True Warp.defaultSettings
100120

101121
defaultExceptionResponse :: SomeException -> Wai.Response
102122
defaultExceptionResponse e =
103-
Wai.responseLBS HT.badGateway502
104-
[ (HT.hContentType, "text/plain; charset=utf-8") ]
105-
$ LBS.fromChunks [BS.pack $ show e]
106-
107-
123+
Wai.responseLBS
124+
HT.badGateway502
125+
[(HT.hContentType, "text/plain; charset=utf-8")]
126+
$ LBS.fromChunks [BS.pack $ show e]

0 commit comments

Comments
 (0)