/
Server.hs
146 lines (131 loc) · 4.35 KB
/
Server.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Hydra.API.Server (
Server (..),
ServerCallback,
ServerComponent,
withAPIServer,
APIServerLog,
) where
import Hydra.Prelude hiding (TVar, readTVar)
import Control.Concurrent.STM (TChan, dupTChan, readTChan)
import qualified Control.Concurrent.STM as STM
import Control.Concurrent.STM.TChan (newBroadcastTChanIO, writeTChan)
import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar)
import Control.Exception (IOException)
import qualified Data.Aeson as Aeson
import Hydra.ClientInput (ClientInput)
import Hydra.Ledger (IsTx (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Network (IP, PortNumber)
import Hydra.Party (Party)
import Hydra.ServerOutput (ServerOutput (Greetings, InvalidInput))
import Network.WebSockets (
acceptRequest,
receiveData,
runServer,
sendTextData,
sendTextDatas,
withPingThread,
)
import Test.QuickCheck (oneof)
data APIServerLog
= APIServerStarted {listeningPort :: PortNumber}
| NewAPIConnection
| APIOutputSent {sentOutput :: Aeson.Value}
| APIInputReceived {receivedInput :: Aeson.Value}
| APIInvalidInput {reason :: String, inputReceived :: Text}
deriving stock (Eq, Show, Generic)
deriving anyclass (ToJSON)
instance Arbitrary APIServerLog where
arbitrary =
oneof
[ APIServerStarted <$> arbitrary
, pure NewAPIConnection
, pure $ APIOutputSent (Aeson.Object mempty)
, pure $ APIInputReceived (Aeson.Object mempty)
, APIInvalidInput <$> arbitrary <*> arbitrary
]
-- | Handle to provide a means for sending server outputs to clients.
newtype Server tx m = Server
{ -- | Send some output to all connected clients.
sendOutput :: ServerOutput tx -> m ()
}
-- | Callback for receiving client inputs.
type ServerCallback tx m = ClientInput tx -> m ()
-- | A type tying both receiving input and sending output into a /Component/.
type ServerComponent tx m a = ServerCallback tx m -> (Server tx m -> m a) -> m a
withAPIServer ::
IsTx tx =>
IP ->
PortNumber ->
Party ->
Tracer IO APIServerLog ->
ServerComponent tx IO ()
withAPIServer host port party tracer callback action = do
responseChannel <- newBroadcastTChanIO
history <- newTVarIO [Greetings party]
race_
(runAPIServer host port tracer history callback responseChannel)
. action
$ Server
{ sendOutput = \output -> atomically $ do
modifyTVar' history (output :)
writeTChan responseChannel output
}
runAPIServer ::
forall tx.
IsTx tx =>
IP ->
PortNumber ->
Tracer IO APIServerLog ->
TVar [ServerOutput tx] ->
(ClientInput tx -> IO ()) ->
TChan (ServerOutput tx) ->
IO ()
runAPIServer host port tracer history callback responseChannel = do
traceWith tracer (APIServerStarted port)
handle onIOException $
runServer (show host) (fromIntegral port) $ \pending -> do
con <- acceptRequest pending
chan <- STM.atomically $ dupTChan responseChannel
traceWith tracer NewAPIConnection
forwardHistory con
withPingThread con 30 (pure ()) $
race_ (receiveInputs con) (sendOutputs chan con)
where
onIOException ioException =
throwIO $
RunServerException
{ ioException
, host
, port
}
sendOutputs chan con = forever $ do
response <- STM.atomically $ readTChan chan
let sentResponse = Aeson.encode response
sendTextData con sentResponse
traceWith tracer (APIOutputSent $ toJSON response)
receiveInputs con = forever $ do
msg <- receiveData con
case Aeson.eitherDecode msg of
Right input -> do
traceWith tracer (APIInputReceived $ toJSON input)
callback input
Left e -> do
-- XXX(AB): toStrict might be problematic as it implies consuming the full
-- message to memory
let clientInput = decodeUtf8With lenientDecode $ toStrict msg
sendTextData con $ Aeson.encode $ InvalidInput @tx e clientInput
traceWith tracer (APIInvalidInput e clientInput)
forwardHistory con = do
hist <- STM.atomically (readTVar history)
let encodeAndReverse xs serverOutput = Aeson.encode serverOutput : xs
sendTextDatas con $ foldl' encodeAndReverse [] hist
data RunServerException = RunServerException
{ ioException :: IOException
, host :: IP
, port :: PortNumber
}
deriving (Show)
instance Exception RunServerException