1 files changed, 65 insertions, 0 deletions
diff --git a/net/Server.hs b/net/Server.hs
new file mode 100644
index 0000000..0e53330
--- /dev/null
+++ b/net/Server.hs
@@ -0,0 +1,65 @@
+-- Echo server program
+module Main (main) where
+
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (unless, forever, void)
+
+import qualified Data.ByteString as S
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+
+join :: String -> [String] -> String
+join delim [] = ""
+join delim (s : []) = s
+join delim (s : rest) = 
+  s ++ delim ++ join delim rest
+
+packStr :: String -> S.ByteString
+packStr = encodeUtf8 . T.pack
+
+(+++) = S.append
+
+response =  join "\n" 
+                 [ "HTTP/1.1 200 OK"
+                 , "Content-Type: text/html; charset=utf-8"
+                 , "Connection: keep-alive"
+                 , ""
+                 , "<i>PRIVET</i>"
+                 ]
+
+main :: IO ()
+main = runTCPServer Nothing "3000" talk
+  where
+    talk s = do
+        msg <- recv s 1024
+        print msg
+        unless (S.null msg) $ do
+          sendAll s (packStr response)
+          talk s
+
+-- 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)