SimpleServer/SimpleServerByteString.hs at master · AndreasVoellmy/SimpleServer · GitHub

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
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP, ForeignFunctionInterface #-}

import Control.Concurrent (forkIO, threadWaitRead, threadWaitWrite)
import Control.Monad (when, forever, liftM)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (ByteString, pack)
import Data.ByteString.Internal (toForeignPtr)
import Foreign
import Foreign.C.Types
import Network.Socket (Socket(..), SocketType(..), AddrInfoFlag(..),
                       SocketOption(..), accept, addrAddress, addrFamily,
                       addrFlags, bindSocket, defaultProtocol, defaultHints,
                       fdSocket, getAddrInfo, listen, setSocketOption, socket)
import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock)
import Network.Socket.ByteString (recv)
import System.Environment (getArgs)


main = do
  listenSock <- startListenSock
  forever $ do
    (sock, _) <- accept listenSock
    forkIO $ worker sock


startListenSock :: IO Socket
startListenSock = do
  args <- getArgs
  let portNumber = head args
  addrinfos  <- getAddrInfo
                (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                Nothing
                (Just $ portNumber)
  let serveraddr = head addrinfos
  listenSock <- socket (addrFamily serveraddr) Stream defaultProtocol
  bindSocket listenSock $ addrAddress serveraddr
  setSocketOption listenSock ReuseAddr 1
  listen listenSock listenQueueLength
  return listenSock
  where
    listenQueueLength :: Int
    listenQueueLength = 8192


worker :: Socket -> IO ()
worker sock = do
  let (replyFPtr,_,_) = toForeignPtr reply
  withForeignPtr replyFPtr $ serve sock


serve :: Socket -> Ptr Word8 -> IO ()
serve sock replyPtr = loop expectedRequestLength
  where
    loop :: Int -> IO ()
    loop !left
      | left == 0 = do sendAll sock replyPtr replyLen
                       loop expectedRequestLength
      | otherwise = do bs' <- recv sock left
                       if B.length bs' == 0
                         then return ()
                         else loop $ left - B.length bs'

-- REPLY
reply :: ByteString
reply = B.append fauxHeader fauxIndex

replyLen :: Int
replyLen = B.length reply

fauxHeader :: ByteString
fauxHeader = pack s
  where
    s = "HTTP/1.1 200 OK\r\nDate: Tue, 09 Oct 2012 16:36:18 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.8.1\r\nLast-Modified: Mon, 09 Jul 2012 03:42:33 GMT\r\nContent-Type: text/html\r\n\r\n"

fauxIndex :: ByteString
fauxIndex = pack s
  where
    s = "<html>\n<head>\n<title>Welcome to nginx!</title>\n</head>\n<body bgcolor=\"white\" text=\"black\">\n<center><h1>Welcome to nginx!</h1></center>\n</body>\n</html>\n"


-- EXPECTED REQUEST
expectedRequest :: ByteString
expectedRequest =
  pack "GET / HTTP/1.1\r\nHost: 10.12.0.1:8080\r\nUser-Agent: weighttp/0.3\r\nConnection: keep-alive\r\n\r\n"

expectedRequestLength :: Int
expectedRequestLength = B.length expectedRequest

foreign import ccall unsafe "send"
  c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt

send' :: Socket         -- ^ Connected socket
         -> Ptr a       -- ^ Pointer to beginning of data to send
         -> Int         -- ^ Amount of data to send
         -> IO Int      -- ^ Number of bytes sent
send' (MkSocket s _ _ _ _) ptr len =
    liftM fromIntegral $
        throwSocketErrorIfMinus1RetryMayBlock "send'"
        (threadWaitWrite $ fromIntegral s) $
        c_send s ptr (fromIntegral len) 0

sendAll :: Socket      -- ^ Connected socket
           -> Ptr a
           -> Int
           -> IO ()
sendAll !sock !ptr !len = do
    sent <- send' sock ptr len
    when (sent < len) $ sendAll sock (ptr `plusPtr` sent) (len - sent)