Main.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

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 (decodeUtf8, encodeUtf8)

import Network.Socket
import Network.Socket.ByteString (recv, sendAll)

import Web.Utils
import Web.Response
import Web.Router
import Routes

import Settings (host, port)

main :: IO ()
main = do
  let hostStr = case host of
                  Just smt -> smt
                  Nothing  -> "0.0.0.0"

  putStrLn $ "Server launched on " ++ hostStr ++ ":" ++ port
  runTCPServer host port talk
  where
    talk s = do
      msg <- recv s 1024
      putStrLn "Got request"
      unless (S.null msg) $ do
        let (request, _, _) = parseHttp $ decodeUtf8 msg
        response <- resolve routesTable $ request
        sendAll s $ encodeUtf8 (formResponse response)

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)