{-# LANGUAGE OverloadedStrings #-} module Server where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.IORef import Network.TLS import Prelude hiding (getLine) import Imports server :: Context -> Bool -> IO () server ctx showRequest = do recvRequest ctx showRequest sendData ctx $ "HTTP/1.1 200 OK\r\n" <> "Context-Type: text/html\r\n" <> "Content-Length: " <> BL8.pack (show (BL8.length body)) <> "\r\n" <> "\r\n" <> body where body = "<Hello world!" recvRequest :: Context -> Bool -> IO () recvRequest ctx showRequest = do getLine <- newSource ctx loop getLine where loop getLine = do bs <- getLine when (bs /= "") $ do when showRequest $ do BS.putStr bs BS.putStr "\n" loop getLine newSource :: Context -> IO (IO ByteString) newSource ctx = do ref <- newIORef "" return $ getline ref where getline :: IORef ByteString -> IO ByteString getline ref = do bs0 <- readIORef ref case BS.breakSubstring "\r\n" bs0 of (_, "") -> do bs1 <- recvData ctx writeIORef ref (bs0 <> bs1) getline ref (bs1, bs2) -> do writeIORef ref $ BS.drop 2 bs2 return bs1