Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Control.Concurrent      (forkIO)
import           Control.Monad           (forever)
import           Data.ByteString.Builder (Builder, hPutBuilder, lazyByteString)
import qualified Data.ByteString.Lazy    as BS
import           Data.Monoid             ((<>))
import           GHC.IO.Handle           (BufferMode (..), hClose,
                                          hSetBinaryMode, hSetBuffering)
import           Network.Socket          hiding (recv)
import           System.IO               (IOMode (..))

main :: IO ()
main = withSocketsDo $
  do addrinfos <- getAddrInfo
                  (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                  Nothing
                  (Just "3000")
     let serveraddr = head addrinfos
     sock <- socket (addrFamily serveraddr) Stream defaultProtocol
     bindSocket sock (addrAddress serveraddr)
     listen sock 5
     forever $ accept sock >>= forkIO . handleClientRequest

handleClientRequest :: (Socket, a) -> IO ()
handleClientRequest (conn, _) = do
  -- sendAll conn "HTTP/1.1 200 Ok\r\ncontent-length: 0\r\n\r\n"
  handle <- socketToHandle conn WriteMode
  hSetBinaryMode handle True
  hSetBuffering handle (BlockBuffering (Just 1024))
  hPutBuilder handle $
    buildResponse [ "HTTP/1.1 200 Ok\r\n"
                  , "content-length: 0\r\n\r\n"
                  ]
  hClose handle

buildResponse :: [BS.ByteString] -> Builder
buildResponse = foldr ((<>) . lazyByteString) mempty
-- buildResponse [] = mempty
-- buildResponse (x:xs) = lazyByteString x <> buildResponse xs