-- 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)