Skip to content

Commit 95df92b

Browse files
parsonsmattparsonsmatt
committed
better server watch mode
1 parent ffd619f commit 95df92b

File tree

10 files changed

+211
-107
lines changed

10 files changed

+211
-107
lines changed

‎Makefile‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,10 @@ help: ## Print documentation
44
ghcid-devel: ## Run the server in fast development mode. See DevelMain for details.
55
ghcid \
66
--command "stack ghci servant-persistent" \
7-
--test "DevelMain.update"
7+
--test DevelMain.update \
8+
--warnings \
9+
--restart ./servant-persistent.cabal \
10+
--restart ./stack.yaml
811

912
imports: ## Format all the imports that have changed since the master branch.
1013
./stylish-haskell.sh

‎app/Main.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
module Main where
22

3-
import Init (runApp)
3+
import Init (runAppDevel)
44

55
-- | The 'main' function gathers the required environment information and
66
-- initializes the application.
77
main :: IO ()
8-
main = runApp
8+
main = runAppDevel

‎assets/api.js‎

Lines changed: 50 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -1,86 +1,85 @@
11

2-
var getUsers = function(onSuccess, onError)
3-
{
2+
var getUsers = function(onSuccess, onError) {
43
var xhr = new XMLHttpRequest();
54
xhr.open('GET', '/users', true);
6-
xhr.setRequestHeader("Accept","application/json");
7-
xhr.onreadystatechange = function (e) {
8-
if (xhr.readyState == 4) {
9-
if (xhr.status == 204 || xhr.status == 205) {
5+
xhr.setRequestHeader('Accept', 'application/json');
6+
xhr.onreadystatechange = function () {
7+
var res = null;
8+
if (xhr.readyState === 4) {
9+
if (xhr.status === 204 || xhr.status === 205) {
1010
onSuccess();
1111
} else if (xhr.status >= 200 && xhr.status < 300) {
12-
var value = JSON.parse(xhr.responseText);
13-
onSuccess(value);
12+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
13+
if (res) onSuccess(res);
1414
} else {
15-
var value = JSON.parse(xhr.responseText);
16-
onError(value);
15+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
16+
if (res) onError(res);
1717
}
1818
}
19-
}
19+
};
2020
xhr.send(null);
21-
}
21+
};
2222

23-
var getUsersByName = function(name, onSuccess, onError)
24-
{
23+
var getUsersByName = function(name, onSuccess, onError) {
2524
var xhr = new XMLHttpRequest();
2625
xhr.open('GET', '/users/' + encodeURIComponent(name) + '', true);
27-
xhr.setRequestHeader("Accept","application/json");
28-
xhr.onreadystatechange = function (e) {
29-
if (xhr.readyState == 4) {
30-
if (xhr.status == 204 || xhr.status == 205) {
26+
xhr.setRequestHeader('Accept', 'application/json');
27+
xhr.onreadystatechange = function () {
28+
var res = null;
29+
if (xhr.readyState === 4) {
30+
if (xhr.status === 204 || xhr.status === 205) {
3131
onSuccess();
3232
} else if (xhr.status >= 200 && xhr.status < 300) {
33-
var value = JSON.parse(xhr.responseText);
34-
onSuccess(value);
33+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
34+
if (res) onSuccess(res);
3535
} else {
36-
var value = JSON.parse(xhr.responseText);
37-
onError(value);
36+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
37+
if (res) onError(res);
3838
}
3939
}
40-
}
40+
};
4141
xhr.send(null);
42-
}
42+
};
4343

44-
var postUsers = function(body, onSuccess, onError)
45-
{
44+
var postUsers = function(body, onSuccess, onError) {
4645
var xhr = new XMLHttpRequest();
4746
xhr.open('POST', '/users', true);
48-
xhr.setRequestHeader("Accept","application/json");
49-
xhr.setRequestHeader("Content-Type","application/json");
50-
xhr.onreadystatechange = function (e) {
51-
if (xhr.readyState == 4) {
52-
if (xhr.status == 204 || xhr.status == 205) {
47+
xhr.setRequestHeader('Accept', 'application/json');
48+
xhr.setRequestHeader('Content-Type', 'application/json');
49+
xhr.onreadystatechange = function () {
50+
var res = null;
51+
if (xhr.readyState === 4) {
52+
if (xhr.status === 204 || xhr.status === 205) {
5353
onSuccess();
5454
} else if (xhr.status >= 200 && xhr.status < 300) {
55-
var value = JSON.parse(xhr.responseText);
56-
onSuccess(value);
55+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
56+
if (res) onSuccess(res);
5757
} else {
58-
var value = JSON.parse(xhr.responseText);
59-
onError(value);
58+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
59+
if (res) onError(res);
6060
}
6161
}
62-
}
63-
xhr.send(JSON.stringify(body)
64-
);
65-
}
62+
};
63+
xhr.send(JSON.stringify(body));
64+
};
6665

67-
var getMetrics = function(onSuccess, onError)
68-
{
66+
var getMetrics = function(onSuccess, onError) {
6967
var xhr = new XMLHttpRequest();
7068
xhr.open('GET', '/metrics', true);
71-
xhr.setRequestHeader("Accept","application/json");
72-
xhr.onreadystatechange = function (e) {
73-
if (xhr.readyState == 4) {
74-
if (xhr.status == 204 || xhr.status == 205) {
69+
xhr.setRequestHeader('Accept', 'application/json');
70+
xhr.onreadystatechange = function () {
71+
var res = null;
72+
if (xhr.readyState === 4) {
73+
if (xhr.status === 204 || xhr.status === 205) {
7574
onSuccess();
7675
} else if (xhr.status >= 200 && xhr.status < 300) {
77-
var value = JSON.parse(xhr.responseText);
78-
onSuccess(value);
76+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
77+
if (res) onSuccess(res);
7978
} else {
80-
var value = JSON.parse(xhr.responseText);
81-
onError(value);
79+
try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
80+
if (res) onError(res);
8281
}
8382
}
84-
}
83+
};
8584
xhr.send(null);
86-
}
85+
};

‎servant-persistent.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,11 +28,13 @@ executable perservant
2828
, warp
2929
, monad-logger
3030
, safe
31+
, safe-exceptions
3132
, monad-metrics
3233
, wai-middleware-metrics
3334
, microlens
3435
, ekg
3536
, ekg-core
37+
, say
3638
hs-source-dirs:
3739
app
3840
default-language:

‎src/Config.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,14 @@
11
{-# LANGUAGE FlexibleInstances #-}
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33
{-# LANGUAGE MultiParamTypeClasses #-}
4-
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE StrictData, OverloadedStrings #-}
55

66
{-# OPTIONS_GHC -fno-warn-orphans #-}
77

88
module Config where
99

1010
import Control.Concurrent (ThreadId)
11-
import Control.Exception (throwIO)
11+
import Control.Exception.Safe (throwIO)
1212
import Control.Monad.Except (ExceptT, MonadError)
1313
import Control.Monad.IO.Class
1414
import Control.Monad.Logger (MonadLogger(..))

‎src/DevelMain.hs‎

Lines changed: 52 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE OverloadedStrings #-}
1+
{-# LANGUAGE OverloadedStrings,TypeApplications #-}
22

33
-- | Running your app inside GHCi.
44
--
@@ -18,38 +18,51 @@ module DevelMain where
1818

1919
import Prelude
2020

21+
import Data.Typeable
22+
import qualified Data.Text as Text
23+
import Data.Text (Text)
24+
import System.IO
2125
import Control.Concurrent
22-
(MVar, ThreadId, forkIO, killThread, newEmptyMVar, putMVar, takeMVar)
23-
import Control.Exception (finally)
24-
import Control.Monad ((>=>))
26+
import Control.Exception.Safe
27+
import Control.Monad
2528
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
2629
import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
2730
import GHC.Word (Word32)
28-
import Init (runApp)
31+
import Init (runAppDevel)
32+
import Say
33+
import Data.Monoid
34+
35+
tshow :: Show a => a -> Text
36+
tshow = Text.pack . show
2937

3038
-- | Start or restart the server.
3139
-- newStore is from foreign-store.
3240
-- A Store holds onto some data across ghci reloads
3341
update :: IO ()
3442
update = do
43+
hSetBuffering stdout NoBuffering
44+
hSetBuffering stderr NoBuffering
3545
mtidStore <- lookupStore tidStoreNum
3646
case mtidStore of
37-
-- no server running
38-
Nothing -> do
39-
done <- storeAction doneStore newEmptyMVar
40-
tid <- start done
41-
_ <- storeAction (Store tidStoreNum) (newIORef tid)
42-
return ()
43-
-- server is already running
44-
Just tidStore -> restartAppInNewThread tidStore
47+
Nothing -> do
48+
say "no server running"
49+
done <- storeAction doneStore newEmptyMVar
50+
tid <- start done
51+
_ <- storeAction (Store tidStoreNum) (newIORef tid)
52+
return ()
53+
Just tidStore -> do
54+
say "restarting app..."
55+
restartAppInNewThread tidStore
4556
where
4657
doneStore :: Store (MVar ())
4758
doneStore = Store 0
4859

4960
-- shut the server down with killThread and wait for the done signal
5061
restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
5162
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
63+
say $ "killing thread: " <> tshow tid
5264
killThread tid
65+
say $ "taking mvar"
5366
withStore doneStore takeMVar
5467
readStore doneStore >>= start
5568

@@ -58,22 +71,41 @@ update = do
5871
start :: MVar () -- ^ Written to when the thread is killed.
5972
-> IO ThreadId
6073
start done =
61-
forkIO (finally runApp
62-
-- Note that this implies concurrency
63-
-- between shutdownApp and the next app that is starting.
64-
-- Normally this should be fine
65-
(putMVar done ()))
74+
myThreadId <* (do
75+
say "in forkFinally"
76+
runAppDevel `catch` \(SomeException e) -> do
77+
say "!!! exception in runAppDevel !!!"
78+
say $ "X exception type: " <> tshow (typeOf e)
79+
say $ "X exception : " <> tshow e
80+
say "runAppDevel terminated"
81+
)
82+
`catch`
83+
(\(SomeException err) -> do
84+
say "finally action"
85+
hFlush stdout
86+
hFlush stderr
87+
putMVar done ()
88+
say $ "Got Exception: " <> tshow err
89+
throwIO err
90+
)
91+
`finally`
92+
(do
93+
say "finally action"
94+
hFlush stdout
95+
hFlush stderr
96+
putMVar done ()
97+
)
6698

6799
-- | kill the server
68100
shutdown :: IO ()
69101
shutdown = do
70102
mtidStore <- lookupStore tidStoreNum
71103
case mtidStore of
72104
-- no server running
73-
Nothing -> putStrLn "no app running"
105+
Nothing -> say "no app running"
74106
Just tidStore -> do
75107
withStore tidStore $ readIORef >=> killThread
76-
putStrLn "App is shutdown"
108+
say "App is shutdown"
77109

78110
tidStoreNum :: Word32
79111
tidStoreNum = 1

0 commit comments

Comments
 (0)