summaryrefslogtreecommitdiff
path: root/Presence/ServerC.hs
blob: b16a0099f674e5b951749c18c1264d43ae17703b (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
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module ServerC
    ( doServer
    , ConnId(..)
    , ServerHandle
    , quitListening
    , dummyServerHandle
    ) where

import Network.Socket as Socket
import Data.ByteString.Lazy.Char8 as L 
    ( putStrLn )
import Data.ByteString.Char8
    ( hGetNonBlocking
    )
import qualified Data.ByteString.Char8 as S
    ( hPutStr
    , hPutStrLn
    )
import System.IO 
    ( IOMode(..)
    , hSetBuffering
    , BufferMode(..)
    , hWaitForInput
    , hClose
    , hIsEOF
    )
import Control.Monad
import Control.Concurrent (forkIO,threadDelay)
import Control.Exception (handle,SomeException(..))
import Data.HList
import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import System.IO.Error

import Data.Conduit
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.ByteString as S (ByteString)
import System.IO (Handle)
import Control.Concurrent.MVar (newMVar)

import ByteStringOperators
import SocketLike



newtype ConnId = ConnId Int
  deriving Eq

newtype ServerHandle = ServerHandle Socket

dummyServerHandle = do
    mvar <- newMVar Closed
    let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar
    return (ServerHandle sock)

quitListening :: ServerHandle -> IO ()
quitListening (ServerHandle socket) = sClose socket


data AcceptResult =
  GotConnection (Socket,SockAddr)
  | Retry
  | QuitOnException

doServer ::
  MonadIO m =>
    HCons Socket.Family (HCons PortNumber l)
    -> (HCons RestrictedSocket (HCons ConnId l)
        -> Source m S.ByteString 
        -> Sink S.ByteString m ()
        -> IO ())
    -> IO ServerHandle
doServer (HCons family port) g = runServer port (runConn g)
 where
    runServer (HCons port st) go = do
        sock <- socket family Stream 0
        setSocketOption sock ReuseAddr 1
        case family of
          AF_INET  -> bindSocket sock (SockAddrInet port iNADDR_ANY)
          AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 0)
        listen sock 2
        forkIO $ do
            mainLoop sock (ConnId 0) go
            -- L.putStrLn $ "quit accept loop"
        return (ServerHandle sock)
     where
        mainLoop sock idnum@(ConnId n) go = do
            let doException ioerror = do
                let typ = ioeGetErrorType ioerror
                case bshow typ of

                  -- ResourceExhausted
                  "resource exhausted" -> return Retry

                  -- InvalidArgument
                  "invalid argument"   -> L.putStrLn "quit accept-loop." >> return QuitOnException

                  _  -> do
                    L.putStrLn ("accept-loop exception: " <++> bshow ioerror <++> "\n")
                    return QuitOnException

            mcon <- handle doException $ fix $ \loop -> do
                con <- accept sock
                return $ GotConnection con
            case mcon of
              GotConnection con -> do
                forkIO $ go (idnum `HCons` st) con 
                mainLoop sock (ConnId (n+1)) go
              Retry           -> threadDelay 500000 >> mainLoop sock idnum go
              QuitOnException -> return ()

packets :: MonadIO m => Handle -> Source m S.ByteString
packets h = do
    packet <- liftIO $ getPacket h
    yield packet
    isEof <- liftIO $ hIsEOF h
    when (not isEof) (packets h)
 where
    getPacket h = do { hWaitForInput h (-1) ; hGetNonBlocking h 1024 }

outgoing :: MonadIO m => Handle -> Sink S.ByteString m ()
outgoing h = do
    -- liftIO . L.putStrLn $ "outgoing: waiting"
    mpacket <- await
    -- liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket
    maybe (return ()) 
          (\r -> (liftIO . S.hPutStrLn h $ r) >> outgoing h) 
          mpacket
    



runConn ::
  MonadIO m =>
  (HCons RestrictedSocket st 
    -> Source m S.ByteString 
    -> Sink S.ByteString m () 
    -> IO ())
  -> st 
  -> (Socket, t) 
  -> IO ()
runConn g st (sock,_) = do
        h <- socketToHandle sock ReadWriteMode
        hSetBuffering h NoBuffering
        let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
        handle doException (g (restrictSocket sock `HCons` st) (packets h) (outgoing h))
        hClose h