server.hs

module Lib
    ( startServer
    ) where

import Control.Exception
import qualified Data.ByteString.Char8 as S
import Network.Socket hiding (send, recv)
import Network.Socket.ByteString
import System.Directory

import System.IO

data HttpResp = Resp { code :: Int
                     , message :: String
                     }

data HttpMethod = Get
  deriving (Show)

data HttpReq = Req { method :: HttpMethod
                   , location :: String
                   , protocol :: String
                   , headers :: [String]
                   } deriving (Show)

instance Show HttpResp where
  show (Resp code msg) = "HTTP/1.1 " ++ show code ++ " " ++ msg ++ "\n"

startServer :: IO ()
startServer = do
  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bind sock (SockAddrInet 4242 iNADDR_ANY)
  listen sock 2
  mainLoop sock

mainLoop :: Socket -> IO ()
mainLoop sock = do
  conn <- accept sock
  handleConn conn
  mainLoop sock

parseLoc :: String -> String
parseLoc = (flip (!!) $ 1) . words

parseReq :: S.ByteString -> HttpReq
parseReq req = Req { method = method
                   , location = loc
                   , protocol = "HTTP/1.1"
                   , headers = tail lines }
  where lines = map S.unpack . S.split '\n' $ req
        -- first line is going to be method/location
        method = case head . words $ head lines of
                   "GET" -> Get
        loc = parseLoc $ head lines

getFile :: FilePath -> IO (Handle, HttpResp)
getFile path = do
  let escPath = "." ++ path
  fileExists <- doesFileExist escPath
  if fileExists
    then do handle <- openBinaryFile escPath ReadMode
            let resp = Resp 200 "OK"
            return $ (handle, resp)
    else do handle <- openBinaryFile "404.html" ReadMode
            let resp = Resp 404 "NOT FOUND"
            return $ (handle, resp)

handleConn :: (Socket, SockAddr) -> IO ()
handleConn (sock, addr) = do
  input <- recv sock 1024
  let req = parseReq input
  putStrLn $ "connection from: " ++ show addr
  putStrLn $ "request: " ++ show req
  (handle, resp) <- getFile $ location req
  msg <- hGetContents handle
  send sock . S.pack $ show $ resp
  send sock . S.pack $ "Content-Length: " ++ (show $ length msg) ++ "\n\n"
  send sock . S.pack $ msg
  hClose handle
  close sock