{-# LANGUAGE OverloadedStrings #-} | |
-- Echo server program | |
module Main (main) where | |
import Control.Concurrent | |
import Control.Concurrent.MVar | |
import qualified Control.Exception as E | |
import Control.Monad (unless, forever, void) | |
import qualified Data.ByteString as S | |
import qualified Data.ByteString.Char8 as S8 | |
import Network.Socket | |
import Network.Socket.ByteString (recv, sendAll) | |
resp = "HTTP/1.0 200 OK\n\n" | |
main :: IO () | |
main = do | |
forkIO $ runTCPServer Nothing "3000" (talk) | |
forever $ threadDelay 10000000 | |
talk s = do | |
msg <- recv s 1024 | |
sendAll s resp | |
-- from the "network-run" package. | |
runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a | |
runTCPServer mhost port server = withSocketsDo $ do | |
addr <- resolve | |
E.bracket (open addr) close loop | |
where | |
resolve = do | |
let hints = defaultHints { | |
addrFlags = [AI_PASSIVE] | |
, addrSocketType = Stream | |
} | |
head <$> getAddrInfo (Just hints) mhost (Just port) | |
open addr = do | |
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) | |
setSocketOption sock ReuseAddr 1 | |
withFdSocket sock setCloseOnExecIfNeeded | |
bind sock $ addrAddress addr | |
listen sock 1024 | |
return sock | |
loop sock = forever $ do | |
(conn, _peer) <- accept sock | |
void $ forkFinally (server conn) (const $ gracefulClose conn 5000) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment