summaryrefslogtreecommitdiff
path: root/Presence/Server.hs
blob: 5e54ff27628938aa5c96fd290617ad54b1791dd2 (plain)
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TupleSections      #-}
#ifdef TEST
{-# LANGUAGE FlexibleInstances #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Server
--
-- Maintainer  :  joe@jerkface.net
-- Stability   :  experimental
-- 
-- A TCP client/server library.
--
-- TODO: 
--
--  * interface tweaks
--
module Server where

import Data.ByteString (ByteString,hGetNonBlocking)
import qualified Data.ByteString.Char8 as S ( hPutStrLn, hPutStr, pack)
#if MIN_VERSION_containers(0,5,0)
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
#else
import qualified Data.Map as Map
import           Data.Map (Map)
#endif
import Data.Monoid ( (<>) )
import Control.Concurrent
import Control.Concurrent.STM
-- import Control.Concurrent.STM.TMVar
-- import Control.Concurrent.STM.TChan
-- import Control.Concurrent.STM.Delay
import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
import Control.Monad
import Control.Monad.Fix
-- import Control.Monad.STM
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class (MonadIO (liftIO))
import System.IO.Error (ioeGetErrorType)
import System.IO 
    ( IOMode(..)
    , hSetBuffering
    , BufferMode(..)
    , hWaitForInput
    , hClose
    , hIsEOF
    , stderr
    , stdout
    , Handle
    , hFlush
    )
import Network.Socket
import Network.BSD 
    ( getProtocolNumber
    )   
import Debug.Trace
import Data.Time.Clock (UTCTime,getCurrentTime)
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)

todo = error "unimplemented"

type TimeOut = Int      -- ^ miliseconds
type PingInterval = Int -- ^ miliseconds

-- | This object is passed with the 'Listen' and 'Connect'
-- instructions in order to control the behavior of the 
-- connections that are established.  It is parameterized
-- by a user-suplied type @conkey@ that is used as a lookup
-- key for connections.
data ConnectionParameters conkey =
  ConnectionParameters 
    { pingInterval :: PingInterval
    -- ^ The miliseconds of idle to allow before a 'RequiresPing'
    -- event is signaled.
    , timeout :: TimeOut
    -- ^ The miliseconds of idle after 'RequiresPing' is signaled
    -- that are necessary for the connection to be considered
    -- lost and signalling 'EOF'.
    , makeConnKey :: (Socket,SockAddr) -> IO conkey
    -- ^ This action creates a lookup key for a new connection.  If 'duplex'
    -- is 'True' and the result is already assocatied with an established
    -- connection, then an 'EOF' will be forced before the the new
    -- connection becomes active.
    --
    , duplex :: Bool
    -- ^ If True, then the connection will be treated as a normal
    -- two-way socket.  Otherwise, a readable socket is established
    -- with 'Listen' and a writable socket is established with
    -- 'Connect' and they are associated when 'makeConnKey' yields
    -- same value for each.
    }

-- | Use this function to select appropriate default values for
-- 'ConnectionParameters' other than 'makeConnKey'.
--
-- Current defaults:
--
--  * 'pingInterval' = 28000
--
--  * 'timeout' = 2000
--
--  * 'duplex' = True
--
connectionDefaults
  :: ((Socket, SockAddr) -> IO conkey) -> ConnectionParameters conkey
connectionDefaults f = ConnectionParameters
    { pingInterval = 28000
    , timeout = 2000
    , makeConnKey = f
    , duplex = True
    }

-- | Instructions for a 'Server' object
--
-- To issue a command, put it into the 'serverCommand' TMVar.
data ServerInstruction conkey
    = Quit
    -- ^ kill the server.  This command is automatically issued when
    -- the server is released.
    | Listen PortNumber (ConnectionParameters conkey)
    -- ^ listen for incomming connections
    | Connect SockAddr  (ConnectionParameters conkey)
    -- ^ connect to addresses
    | Ignore PortNumber
    -- ^ stop listening on specified port
    | Send conkey ByteString
    -- ^ send bytes to an established connection

#ifdef TEST
deriving instance Show conkey => Show (ServerInstruction conkey)
instance Show (a -> b) where show _ = "<function>"
deriving instance Show conkey => Show (ConnectionParameters conkey)
#endif

-- | This type specifies which which half of a half-duplex
-- connection is of interest.
data InOrOut = In | Out 
 deriving (Enum,Eq,Ord,Show,Read)

-- | These events may be read from 'serverEvent' TChannel.
--
data ConnectionEvent b
    = Got b
    -- ^ Arrival of data from a socket
    | Connection (STM Bool) (IO (Maybe ByteString)) (ByteString -> IO Bool)
    -- ^ A new connection was established
    | ConnectFailure SockAddr
    -- ^ A 'Connect' command failed.
    | HalfConnection InOrOut
    -- ^ Half of a half-duplex connection is avaliable.
    | EOF 
    -- ^ A connection was terminated
    | RequiresPing 
    -- ^ 'pingInterval' miliseconds of idle was experienced

#ifdef TEST
instance Show (IO a) where show _ = "<IO action>"
instance Show (STM a) where show _ = "<STM action>"
instance Eq (ByteString -> IO Bool) where (==) _ _ = True
instance Eq (IO (Maybe ByteString)) where (==) _ _ = True
instance Eq (STM Bool) where (==) _ _ = True
deriving instance Show b => Show (ConnectionEvent b)
deriving instance Eq   b => Eq   (ConnectionEvent b)
#endif

-- | This object accepts commands and signals events and maintains
-- the list of currently listening ports and established connections.
data Server a
 = Server { serverCommand :: TMVar (ServerInstruction a)
          , serverEvent :: TChan (a, ConnectionEvent ByteString)
          , serverReleaseKey :: ReleaseKey
          , conmap :: TVar (Map a (TMVar (STM (IO ())), ConnectionState))
          , listenmap :: TVar (Map PortNumber (ThreadId,Socket))
          }

-- | Construct a 'Server' object.  Use 'Control.Monad.Trans.Resource.ResourceT'
-- to ensure proper cleanup.  For example,
--
-- > import Server
-- > import Control.Monad.Trans.Resource (runResourceT)
-- > import Control.Monad.IO.Class       (liftIO)
-- > import Control.Monad.STM            (atomically)
-- > import Control.Concurrent.STM.TMVar (putTMVar)
-- > import Control.Concurrent.STM.TChan (readTChan)
-- > 
-- > main = runResourceT $ do
-- >   sv <- server
-- >   let params = connectionDefaults (return . snd)
-- >   liftIO . atomically $ putTMVar (serverCommand sv) (Listen 2942 params)
-- >   let loop = do
-- >          (_,event) <- atomically $ readTChan (serverEvent sv)
-- >          case event of
-- >            Got bytes -> putStrLn $ "got: " ++ show bytes
-- >            _         -> return ()
-- >          case event of EOF -> return ()
-- >                        _   -> loop
-- >   liftIO loop
server :: (Show a,Ord a, MonadIO m, MonadResource m) => m (Server a)
server = do
    (key,cmds) <- allocate (atomically newEmptyTMVar)
                           (atomically . flip putTMVar Quit)
    server <- liftIO . atomically $ do
        tchan    <- newTChan
        conmap   <- newTVar Map.empty
        listenmap<- newTVar Map.empty
        return Server { serverCommand = cmds
                      , serverEvent = tchan
                      , serverReleaseKey = key
                      , conmap = conmap
                      , listenmap = listenmap
                      }
    liftIO $ do
        forkIO $ fix $ \loop -> do
            instr <- atomically $ takeTMVar cmds
            -- warn $ "instr = " <> bshow instr
            let again = do doit server instr
                           -- warn $ "finished " <> bshow instr
                           loop
            case instr of Quit -> closeAll server
                          _    -> again
        return server
 where
  closeAll server = liftIO $ do
    listening <- atomically . readTVar $ listenmap server
    mapM_ killListener   (Map.elems listening)
    cons <- atomically . readTVar $ conmap server
    atomically $ mapM_ (connClose . snd) (Map.elems cons)
    atomically $ mapM_ (connWait . snd) (Map.elems cons)
    atomically $ writeTVar (conmap server) Map.empty


  doit server (Listen port params) = liftIO $ do

    listening <- Map.member port
                 `fmap` atomically (readTVar $ listenmap server)
    when (not listening) $ do

    let family = AF_INET6

    sock <- socket family Stream 0
    setSocketOption sock ReuseAddr 1
    let address =
          case family of
            AF_INET  -> SockAddrInet port iNADDR_ANY
            AF_INET6 -> SockAddrInet6 port 0 iN6ADDR_ANY 0
    fix $ \loop -> do
      handle (\(SomeException e)-> do
                    warn $ "BIND-ERROR:"<>bshow address <> " " <> bshow e
                    threadDelay 5000000
                    loop)
       $ bindSocket sock address
    listen sock 2
    thread <- forkIO $ acceptLoop server params sock
    atomically $ listenmap server `modifyTVar'` Map.insert port (thread,sock)

  doit server (Ignore port) = liftIO $ do
    mb <- atomically $ do 
        map <- readTVar $ listenmap server
        modifyTVar' (listenmap server) $ Map.delete port
        return $ Map.lookup port map
    maybe (return ()) killListener $ mb

  doit server (Send con bs) = liftIO $ do -- . void . forkIO $ do
    map <- atomically $ readTVar (conmap server)
    let post False = (trace ("cant send: "++show bs) $ return ())
        post True  = return ()
    maybe (post False)
          (post <=< flip connWrite bs . snd)
      $ Map.lookup con map

  doit server (Connect addr params) = liftIO $ do
    void . forkIO $ do
        proto <- getProtocolNumber "tcp"
        bracketOnError
            (socket (socketFamily addr) Stream proto)
            (\sock -> do -- only done if there's an error
                         -- Weird hack: puting the would-be peer address
                         -- instead of local socketName
                         conkey <- makeConnKey params (sock,addr) -- XXX: ?
                         sClose sock
                         atomically 
                            $ writeTChan (serverEvent server) 
                                $ (conkey,ConnectFailure addr))
            $ \sock -> do
        connect sock addr
        me <- getSocketName sock
        conkey <- makeConnKey params (sock,me)
        h <- socketToHandle sock ReadWriteMode
        newConnection server params conkey h Out


-- INTERNAL ----------------------------------------------------------
    
{-
hWriteUntilNothing h outs =
    fix $ \loop -> do
        mb <- atomically $ takeTMVar outs
        case mb of Just bs -> do S.hPutStrLn h bs
                                 warn $ "wrote " <> bs
                                 loop
                   Nothing -> do warn $ "wrote Nothing"
                                 hClose h

-}
connRead :: ConnectionState -> IO (Maybe ByteString)
connRead (WriteOnlyConnection w) = do
    -- atomically $ discardContents (threadsChannel w)
    return Nothing
connRead conn = do
    c <- atomically $ getThreads
    threadsRead c
 where
    getThreads =
        case conn of SaneConnection c     -> return c
                     ReadOnlyConnection c -> return c
                     ConnectionPair c w   -> do
                        -- discardContents (threadsChannel w)
                        return c

socketFamily (SockAddrInet _ _)      = AF_INET
socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
socketFamily (SockAddrUnix _)        = AF_UNIX

killListener (thread,sock) = do sClose sock
                                -- killThread thread


conevent con = Connection pingflag read write
 where
    pingflag = swapTVar (pingFlag (connPingTimer con)) False
    read =  connRead con
    write = connWrite con

newConnection server params conkey h inout = do
    hSetBuffering h NoBuffering
    let (forward,idle_ms,timeout_ms) =
            case (inout,duplex params) of
                (Out,True) -> ( const $ return ()
                              , 0
                              , 0 )
                _ -> ( announce . (conkey,) . Got
                     , pingInterval params
                     , timeout params )

    new <- do pinglogic <- pingMachine idle_ms timeout_ms
              connectionThreads h pinglogic
    started <- atomically $ newEmptyTMVar
    kontvar <- atomically newEmptyTMVar
    forkIO $ do
        getkont <- atomically $ takeTMVar kontvar
        kont <- atomically getkont
        kont
    
    atomically $ do
        current <- fmap (Map.lookup conkey) $ readTVar (conmap server)
        case current of
          Nothing -> do
            (newCon,e) <- return $
              if duplex params
                then let newcon = SaneConnection new
                     in ( newcon, (conkey, conevent newcon) )
                else ( case inout of
                        In  -> ReadOnlyConnection new
                        Out -> WriteOnlyConnection new
                     , (conkey, HalfConnection inout) )
            modifyTVar' (conmap server) $ Map.insert conkey (kontvar,newCon)
            announce e
            putTMVar kontvar $ return $ do
                atomically $ putTMVar started ()
                handleEOF conkey kontvar newCon
          Just what@(mvar,_) -> do
            putTMVar kontvar $ return $ return ()
            putTMVar mvar $ do
                kont <- updateConMap conkey new what
                putTMVar started ()
                return kont
#ifdef TEST
    -- enable this for 'Got' events
    forkIO $ do -- inout==In || duplex params then forkIO $ do
        warn $ "waiting gots thread: " <> bshow (conkey,inout)
        atomically $ takeTMVar started
        -- pingBump pinglogic -- start the ping timer
        fix $ \loop -> do
        -- warn $ "read thread: " <> bshow (conkey,inout)
        mb <- threadsRead new
        -- pingBump pinglogic
        warn $ "got: " <> bshow (mb,(conkey,inout))
        maybe (return ())
              (atomically . forward >=> const loop)
              mb
        warn $ "quit-gots: " <> bshow (conkey,inout)
#endif
    return ()
 where

  announce e = writeTChan (serverEvent server) e

  handleEOF conkey mvar newCon = do
    action <- atomically . foldr1 orElse $
        [ takeTMVar mvar >>= id -- passed continuation
        , connWait newCon     >> return eof
        , connWaitPing newCon >>= return . sendPing
        -- , pingWait pingTimer >>= return . sendPing
        ]
    action :: IO ()
   where
    eof = do
            -- warn $ "EOF " <>bshow conkey
            connCancelPing newCon
            atomically $ do connFlush newCon
                            announce (conkey,EOF)
                            modifyTVar' (conmap server)
                                        $ Map.delete conkey
            -- warn $ "fin-EOF "<>bshow conkey

    sendPing PingTimeOut = do
        {-
        let me = connPingTimer newCon
        utc <- getCurrentTime
        let utc' = formatTime defaultTimeLocale "%s" utc
        warn $ "TIMEOUT " <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
        -}
        atomically (connClose newCon)
        eof

    sendPing PingIdle = do
        {-
        let me = connPingTimer newCon
        utc <- getCurrentTime
        let utc' = formatTime defaultTimeLocale "%s" utc
        warn $ "IDLE" <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
        -}
        atomically $ announce (conkey,RequiresPing)
        handleEOF conkey mvar newCon


  updateConMap conkey new (mvar,replaced) = do
    new' <-
        if duplex params then do
            announce (conkey,EOF)
            connClose replaced
            let newcon = SaneConnection new
            announce $ (conkey,conevent newcon)
            return $ newcon
        else
         case replaced of
            WriteOnlyConnection w | inout==In ->
                 do let newcon = ConnectionPair new w
                    announce (conkey,conevent newcon)
                    return newcon
            ReadOnlyConnection r  | inout==Out ->
                 do let newcon = ConnectionPair r new
                    announce (conkey,conevent newcon)
                    return newcon
            _ -> do -- connFlush todo
                    announce (conkey, EOF)
                    connClose replaced
                    announce (conkey, HalfConnection inout)
                    return $ case inout of
                                In  -> ReadOnlyConnection new
                                Out -> WriteOnlyConnection new
    modifyTVar' (conmap server) $ Map.insert conkey (mvar,new')
    return $ handleEOF conkey mvar new'

acceptLoop server params sock = handle (acceptException server params sock) $ do
    con <- accept sock
    conkey <- makeConnKey params con
    h <- socketToHandle (fst con) ReadWriteMode
    newConnection server params conkey h In
    acceptLoop server params sock

acceptException server params sock ioerror = do
    sClose sock
    case show (ioeGetErrorType ioerror) of
      "resource exhausted" -> do -- try again
                                 warn ("acceptLoop: resource exhasted")
                                 threadDelay 500000
                                 acceptLoop server params sock
      "invalid argument"   -> do -- quit on closed socket
                                 return ()
      message              -> do -- unexpected exception
                                 warn ("acceptLoop: "<>bshow message)
                                 return ()



getPacket h = do hWaitForInput h (-1)
                 hGetNonBlocking h 1024



-- | 'ConnectionThreads' is an interface to a pair of threads
-- that are reading and writing a 'Handle'.
data ConnectionThreads = ConnectionThreads
    { threadsWriter :: TMVar (Maybe ByteString)
    , threadsChannel :: TChan ByteString
    , threadsWait :: STM () -- ^ waits for a 'ConnectionThreads' object to close
    , threadsPing :: PingMachine
    }

-- | This spawns the reader and writer threads and returns a newly
-- constructed 'ConnectionThreads' object.
connectionThreads :: Handle -> PingMachine -> IO ConnectionThreads
connectionThreads h pinglogic = do

    (donew,outs) <- atomically $ liftM2 (,) newEmptyTMVar newEmptyTMVar

    (doner,incomming) <- atomically $ liftM2 (,) newEmptyTMVar newTChan
    readerThread <- forkIO $ do
        let finished e  = do
                          hClose h
                          -- warn $ "finished read: " <> bshow (fmap ioeGetErrorType e)
                          -- let _ = fmap ioeGetErrorType e -- type hint
                          let _ = fmap what e where what (SomeException _) = undefined
                          atomically $ do tryTakeTMVar outs
                                          putTMVar outs Nothing -- quit writer
                                          putTMVar doner ()
        handle (finished . Just) $ do
            pingBump pinglogic -- start the ping timer
            fix $ \loop -> do
            packet <- getPacket h
            atomically $ writeTChan incomming packet
            pingBump pinglogic
            isEof <- liftIO $ hIsEOF h
            if isEof then finished Nothing else loop

    writerThread <- forkIO . fix $ \loop -> do
        let finished = do -- warn $ "finished write"
                          -- hClose h -- quit reader
                          throwTo readerThread (ErrorCall "EOF")
                          atomically $ putTMVar donew ()
        mb <- atomically $ readTMVar outs
        case mb of Just bs -> handle (\(SomeException e)->finished)
                                     (do S.hPutStr h bs
                                         atomically $ takeTMVar outs
                                         loop)
                   Nothing -> finished

    let wait = do readTMVar donew
                  readTMVar doner
                  return ()
    return ConnectionThreads { threadsWriter = outs
                             , threadsChannel = incomming
                             , threadsWait = wait
                             , threadsPing = pinglogic }


-- | 'threadsWrite' writes the given 'ByteString' to the
-- 'ConnectionThreads' object.  It blocks until the ByteString
-- is written and 'True' is returned, or the connection is
-- interrupted and 'False' is returned.
threadsWrite :: ConnectionThreads -> ByteString -> IO Bool
threadsWrite c bs = atomically $
    orElse (const False `fmap` threadsWait c)
           (const True  `fmap` putTMVar (threadsWriter c) (Just bs))

-- | 'threadsClose' signals for the 'ConnectionThreads' object
-- to quit and close the associated 'Handle'.  This operation
-- is non-blocking, follow it with 'threadsWait' if you want
-- to wait for the operation to complete.
threadsClose :: ConnectionThreads -> STM ()
threadsClose c = do
    let mvar = threadsWriter c
    v <- tryReadTMVar mvar
    case v of
        Just Nothing -> return () -- already closed
        _            -> putTMVar mvar Nothing

-- | 'threadsRead' blocks until a 'ByteString' is available which
-- is returned to the caller, or the connection is interrupted and
-- 'Nothing' is returned.
threadsRead :: ConnectionThreads -> IO (Maybe ByteString)
threadsRead c = atomically $
    orElse (const Nothing `fmap` threadsWait c)
           (Just          `fmap` readTChan (threadsChannel c))

-- | A 'ConnectionState' is an interface to a single 'ConnectionThreads'
-- or to a pair of 'ConnectionThreads' objects that are considered as one
-- connection.
data ConnectionState =
        SaneConnection ConnectionThreads
        -- ^ ordinary read/write connection
        | WriteOnlyConnection ConnectionThreads
        | ReadOnlyConnection ConnectionThreads
        | ConnectionPair ConnectionThreads ConnectionThreads
        -- ^ Two 'ConnectionThreads' objects, read operations use the
        -- first, write operations use the second.



connWrite :: ConnectionState -> ByteString -> IO Bool
connWrite (ReadOnlyConnection _) bs = return False
connWrite conn bs = threadsWrite c bs
 where
    c = case conn of SaneConnection c      -> c
                     WriteOnlyConnection c -> c
                     ConnectionPair _ c    -> c


mapConn :: Bool ->
            (ConnectionThreads -> STM ()) -> ConnectionState -> STM ()
mapConn both action c =
    case c of
        SaneConnection rw     -> action rw
        ReadOnlyConnection r  -> action r
        WriteOnlyConnection w -> action w
        ConnectionPair r w -> do
            rem <- orElse (const w `fmap` action r)
                          (const r `fmap` action w)
            when both $ action rem 

connClose :: ConnectionState -> STM ()
connClose c = mapConn True threadsClose c

connWait :: ConnectionState -> STM ()
connWait c = doit -- mapConn False threadsWait c
 where
    action = threadsWait
    doit = 
      case c of
        SaneConnection rw     -> action rw
        ReadOnlyConnection r  -> action r
        WriteOnlyConnection w -> action w
        ConnectionPair r w -> do
            rem <- orElse (const w `fmap` action r)
                          (const r `fmap` action w)
            threadsClose rem

connPingTimer c =
    case c of
        SaneConnection rw     -> threadsPing rw
        ReadOnlyConnection r  -> threadsPing r
        WriteOnlyConnection w -> threadsPing w -- should be disabled.
        ConnectionPair r w    -> threadsPing r

connCancelPing c = pingCancel (connPingTimer c)
connWaitPing c = pingWait (connPingTimer c)


connFlush c =
    case c of
        SaneConnection rw     -> waitChan rw
        ReadOnlyConnection r  -> waitChan r
        WriteOnlyConnection w -> return ()
        ConnectionPair r w    -> waitChan r
  where
    waitChan t = do
        b <- isEmptyTChan (threadsChannel t)
        when (not b) retry

bshow e = S.pack . show $ e
warn str = S.hPutStrLn stderr str >> hFlush stderr


data PingEvent = PingIdle | PingTimeOut

data PingMachine = PingMachine
    { pingIdle :: PingInterval
    , pingTimeOut :: TimeOut
    , pingDelay :: TMVar (Int,PingEvent)
    , pingEvent :: TMVar PingEvent
    , pingStarted :: TMVar Bool -- True when a threadDelay is running
    , pingThread :: ThreadId
    , pingFlag :: TVar Bool
    }

pingMachine :: PingInterval -> TimeOut -> IO PingMachine
pingMachine idle timeout = do
    me <- do
        (delayVar,eventVar,startedVar,flag) <- atomically $ do
            d <- newEmptyTMVar
            e <- newEmptyTMVar
            s <- newTMVar False
            f <- newTVar False
            return (d,e,s,f)
        return PingMachine { pingIdle = idle
                           , pingTimeOut = timeout
                           , pingDelay = delayVar
                           , pingEvent = eventVar
                           , pingStarted = startedVar
                           , pingThread = undefined
                           , pingFlag = flag }
    thread <- forkIO . when (pingIdle me /=0) . fix $
      \loop -> do
            (delay,event) <- atomically $ takeTMVar (pingDelay me)
            when (delay /= 0) $ do
            handle (\(ErrorCall _)-> do
                       atomically $ do takeTMVar (pingStarted me)
                                       putTMVar (pingStarted me) False
                       loop)
                   (do atomically $ do takeTMVar (pingStarted me)
                                       putTMVar (pingStarted me) True
                       threadDelay delay
                       atomically $ do takeTMVar (pingStarted me)
                                       putTMVar (pingStarted me) False
                       atomically $ putTMVar (pingEvent me) event
                       case event of PingTimeOut -> return ()
                                     PingIdle    -> loop)

    return me { pingThread = thread }

pingCancel :: PingMachine -> IO ()
pingCancel me = do
    b <- atomically $ do
            tryTakeTMVar (pingDelay me) -- no hang
            putTMVar (pingDelay me) (0,PingTimeOut)
            takeTMVar (pingStarted me)
    when b $ throwTo (pingThread me) $ ErrorCall ""
    atomically $ putTMVar (pingStarted me) b

pingBump :: PingMachine -> IO ()
pingBump me = do
    b <- atomically $ do
            when (pingIdle me /= 0) $ do
              e <- tryReadTMVar (pingDelay me)
              case e of
                  Just (0,PingTimeOut) -> return () -- canceled/fired
                  Just _  -> retry
                  Nothing -> putTMVar (pingDelay me)
                                      (1000*pingIdle me,PingIdle)
            takeTMVar (pingStarted me)
    when b $ throwTo (pingThread me) $ ErrorCall ""
    {-
    utc <- getCurrentTime
    let utc' = formatTime defaultTimeLocale "%s" utc
    warn $ "BUMP " <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
    -}
    atomically $ putTMVar (pingStarted me) b
{-
pingBump me = do
    b <- atomically $ do
             when (pingIdle me /= 0) $ 
                putTMVar (pingDelay me) (1000*pingIdle me,PingIdle)
             readTMVar (pingStarted me)
    when b $ throwTo (pingThread me) $ ErrorCall ""
-}

pingWait :: PingMachine -> STM PingEvent
pingWait me = do
    e <- takeTMVar (pingEvent me)
    case e of
        PingIdle    -> do writeTVar (pingFlag me) True
                          putTMVar (pingDelay me)
                                   (1000*pingTimeOut me,PingTimeOut)
        PingTimeOut -> putTMVar (pingDelay me)
                                (0,PingTimeOut)
    return e