Created
July 16, 2020 20:28
-
-
Save WJWH/97a102791e6ee08d98cc20145d9ba29a to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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