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
|
module Fig.Utils.Net
( server
, client
) where
import Fig.Prelude
import System.IO (IOMode(..), BufferMode(..), hClose, hSetBuffering)
import qualified Control.Concurrent as Conc
import qualified Network.Socket as Sock
newtype FigNetException = FigNetException Text
deriving (Show, Eq, Ord)
instance Exception FigNetException
resolveAddr :: forall m.
(MonadIO m, MonadThrow m) =>
(Maybe Text, Text) ->
Bool ->
m Sock.AddrInfo
resolveAddr (host, port) serv = do
maddr <- liftIO $ headMay <$> Sock.getAddrInfo
(Just $ Sock.defaultHints
{ Sock.addrFlags = [Sock.AI_PASSIVE | serv]
, Sock.addrSocketType = Sock.Stream
}
)
(unpack <$> host)
(Just $ unpack port)
maybe (throwM $ FigNetException "Failed to resolve address") pure maddr
server :: forall m.
(MonadIO m, MonadThrow m, MonadMask m) =>
(Maybe Text, Text) ->
m (Handle -> Sock.SockAddr -> (IO (), IO ())) ->
m ()
server loc onConn = do
addr <- resolveAddr loc True
bracket (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do
liftIO $ Sock.setSocketOption sock Sock.ReuseAddr 1
liftIO $ Sock.withFdSocket sock Sock.setCloseOnExecIfNeeded
liftIO $ Sock.bind sock $ Sock.addrAddress addr
liftIO $ Sock.listen sock 4096
log $ "Listening on " <> tshow (Sock.addrAddress addr)
forever do
let toHandle = bracketOnError (liftIO $ Sock.accept sock) (liftIO . Sock.close . fst) \(conn, peer) ->
liftIO $ (,peer) <$> Sock.socketToHandle conn ReadWriteMode
bracketOnError toHandle (liftIO . hClose . fst) \(hdl, peer) -> do
liftIO $ log $ "Client " <> tshow peer <> " connected"
liftIO $ hSetBuffering hdl LineBuffering
(handler, cleanup) <- ($ peer) . ($ hdl) <$> onConn
liftIO $ Conc.forkFinally handler \res -> do
case res of
Right _ -> log $ "Client " <> tshow peer <> " disconnected"
Left err -> log $ "Client " <> tshow peer <> " disconnected: " <> tshow err
cleanup
hClose hdl
client :: forall m.
(MonadIO m, MonadThrow m, MonadMask m) =>
(Text, Text) ->
m (Handle -> (m (), m ())) ->
m ()
client loc onConn = do
addr <- resolveAddr (first Just loc) False
let openConnectHandle = do
bracketOnError (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do
liftIO . Sock.connect sock $ Sock.addrAddress addr
hdl <- liftIO $ Sock.socketToHandle sock ReadWriteMode
(handler, cleanup) <- ($ hdl) <$> onConn
pure (hdl, handler, cleanup)
bracket openConnectHandle
( \(hdl, _, cleanup) -> do
cleanup
liftIO $ hClose hdl
)
( \(_, handler, _) -> do
handler
)
|
