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
|
{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns #-}
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad
import GHC.Conc hiding (ensureIOManagerIsRunning)
import GHC.Event (ensureIOManagerIsRunning)
import GHC.Event.Manager as M
import Foreign.C.Error
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.ForeignPtr
import Foreign.Ptr
import System.Posix.Types
import Network.Socket hiding (accept)
import qualified Network.Socket.Address as A
import EventSocket (recv, sendAll, c_recv, c_send)
import EventUtil (setNonBlocking)
import Data.ByteString.Char8 as B hiding (zip)
import Data.ByteString.Internal as B
main = do
ensureIOManagerIsRunning
let port = "5002"
myHints = defaultHints { addrFlags = [AI_PASSIVE]
, addrSocketType = Stream }
(ai:_) <- getAddrInfo (Just myHints) Nothing (Just port)
sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)
setSocketOption sock ReuseAddr 1
bind sock (addrAddress ai)
listen sock 1024
mgrs <- replicateM numCapabilities M.new
done <- newEmptyMVar
forM_ (zip [0..] mgrs) $ \(cpu,mgr) -> do
forkOn cpu $ do
accept mgr sock clinet
M.loop mgr
putMVar done ()
takeMVar done
repeatOnIntr :: IO (Either Errno a) -> IO (Either Errno a)
repeatOnIntr act = do
ret <- act
case ret of
l@(Left err) -> if err == eINTR
then repeatOnIntr act
else return l
r -> return r
blocking :: EventManager
-> Either (Fd,Event) FdKey
-> IO (Either Errno a)
-> (Either Fd FdKey -> a -> IO ())
-> IO ()
blocking mgr efdk act on_success = do
ret <- repeatOnIntr act
case ret of
Left err
| err /= eWOULDBLOCK && err /= eAGAIN ->
ioError (errnoToIOError "accept" err Nothing Nothing)
| otherwise ->
case efdk of
Left (fd,evts) -> void (registerFd mgr retry_evt fd evts OneShot)
Right _ -> return ()
Right a -> case efdk of
Left (fd,_evts) -> on_success (Left fd) a
Right fdk -> on_success (Right fdk) a
where retry_evt fdk _ = blocking mgr (Right fdk) act on_success
accept :: EventManager -> Socket
-> (EventManager -> Socket -> SockAddr -> IO ())
-> IO ()
accept mgr sock serve =
withFdSocket sock $ \fd -> do
sk <- getSocketName sock
let sz = A.sizeOfSocketAddress sk
act :: IO (Either Errno (CInt, SockAddr))
act = allocaBytes sz $ \sockaddr -> do
n <- with (fromIntegral sz) $ c_accept (fromIntegral fd) sockaddr
if n == -1
then Left `fmap` getErrno
else do
sa <- peekSockAddr sockaddr
return $! Right (n, sa)
blocking mgr (Left (fromIntegral fd,evtRead)) act $ \_efdk (nfd,addr) -> do
setNonBlocking (fromIntegral nfd)
nsock <- MkSocket nfd family stype proto `fmap` newMVar Connected
serve mgr nsock addr
clinet :: EventManager -> Socket -> SockAddr -> IO ()
clinet mgr sock _ = withFdSocket sock $ \fd -> do
let bufSize = 4096
act = do
fp <- B.mallocByteString bufSize
withForeignPtr fp $ \ptr -> do
ret <- c_recv fd ptr (fromIntegral bufSize) 0
if ret == -1
then Left `fmap` getErrno
else if ret == 0
then return $! Right empty
else do
let !bs = PS (castForeignPtr fp) 0 (fromIntegral ret)
return $! Right bs
blocking mgr (Left (fromIntegral fd,evtRead)) act $ \efdk bs -> do
fd <- case efdk of
Left fd -> return fd
Right fdk -> unregisterFd_ mgr fdk >> return (keyFd fdk)
let (PS fp off len) = "HTTP/1.0 200 OK\r\nConnection: Close\r\nContent-Length: 5\r\n\r\nPong!"
withForeignPtr fp $ \s ->
c_send (fromIntegral fd) (s `plusPtr` off) (fromIntegral len) 0
close sock
client :: EventManager -> Socket -> SockAddr -> IO ()
client _mgr sock _addr = loop' `finally` close sock
where
loop' = do
req <- recvRequest ""
sendAll sock msg
when ("Connection: Keep-Alive" `isInfixOf` req) loop'
msg = "HTTP/1.0 200 OK\r\nConnection: Close\r\nContent-Length: 5\r\n\r\nPong!"
recvRequest r = do
s <- recv sock 4096
let t = B.append r s
if B.null s || "\r\n\r\n" `B.isInfixOf` t
then return t
else recvRequest t
foreign import ccall unsafe "sys/socket.h accept"
c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt
|
