---------------------------------------------------------
-- |
-- Module        : Hack.Handler.SimpleServer
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Unstable
-- Portability   : portable
--
-- A simplistic HTTP server handler for Hack.
--
---------------------------------------------------------
module Hack.Handler.SimpleServer
    ( run
    ) where

import Prelude ( ($), map, IO, String, return
               , length, (==), fail, break, tail, Monad, Int
               , fromIntegral, head, (>=), (.), words, show
               , Read, reads, dropWhile, takeWhile, (/=))

import Hack
import Data.Default

import Data.ByteString.Lazy.Util (takeUntilBlank)
import Data.Mime.Header (parseHeader, lookupHeader)

import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Network
    ( listenOn, accept, sClose, PortID(PortNumber), Socket
    , withSocketsDo)
import Control.Exception (bracket, finally)
import System.IO (Handle, hClose)
import Control.Concurrent
import Control.Monad (unless)
import Data.Maybe (isJust, fromJust, fromMaybe)

run :: Port -> Application -> IO ()
run port = withSocketsDo .
    bracket
        (listenOn $ PortNumber $ fromIntegral port)
        sClose .
        serveConnections port
type Port = Int

serveConnections :: Port -> Application -> Socket -> IO ()
serveConnections port app socket = do
    (conn, _, _) <- accept socket
    forkIO $ serveConnection port app conn
    serveConnections port app socket

serveConnection :: Port -> Application -> Handle -> IO ()
serveConnection port app conn =
    finally
        serveConnection'
        (hClose conn)
    where
        serveConnection' = do
            env <- hParseEnv port conn
            res <- app env
            sendResponse conn res

hParseEnv :: Port -> Handle -> IO Env
hParseEnv port conn = do
    content' <- BS.hGetContents conn
    let (headers', body') = takeUntilBlank content'
    parseEnv port headers' body'

safeRead :: Read a => a -> String -> a
safeRead d s =
  case reads s of
    ((x, _):_) -> x
    [] -> d

-- | Parse a set of header lines and body into a 'Env'.
parseEnv :: Monad m => Port -> [BS.ByteString] -> BS.ByteString -> m Env
parseEnv port lines' body' = do
    let lines = map BSLU.toString lines'
    unless (length lines >= 2) $ fail "Invalid request (not enough lines)"
    (method', rpath', gets) <- parseFirst $ head lines
    let method = safeRead GET method'
    let rpath = '/' : case rpath' of
                        ('/':x) -> x
                        _ -> rpath'
    let heads = map parseHeader $ tail lines'
    let host' = lookupHeader "Host" heads
    unless (isJust host') $ fail "Invalid request (does not include host)"
    let host = fromJust host'
    let len = fromMaybe "0" $ lookupHeader "Content-Length" heads
    let body'' = BS.take (safeRead 0 len) body'
    return $ def
                { requestMethod = method
                , pathInfo = rpath
                , queryString = dropWhile (== '?') gets
                , serverName = takeWhile (/= ':') host
                , serverPort = port
                , http = heads
                , hackInput = body''
                }

parseFirst :: Monad m =>
              String
           -> m (String, String, String)
parseFirst s = do
    let pieces = words s
    unless (length pieces == 3) $ fail "Invalid request (bad first line)"
    let [method, query, http'] = pieces
    unless (http' == "HTTP/1.1") $
        fail "Invalid request (only handle HTTP/1.1)"
    let (rpath, qstring) = break (== '?') query
    return (method, rpath, qstring)

bsFromResponse :: Response -> BS.ByteString
bsFromResponse res = BS.concat
    [ f "HTTP/1.1 "
    , f $ show $ status res
    , f "\r\n"
    , BS.concat $ map (\(x, y) -> BS.concat
        [ f x
        , f ": "
        , f y
        , f "\r\n"
        ]) $ headers res
    , f "\r\n"
    , body res
    ] where f = BSLU.fromString
{-
    hPutStr conn $ "HTTP/1.1 " ++ code res ++ "\r\n"
    hPutStr conn $ "Content-type: " ++ contentType res ++ "\r\n"
    let headers' = map (\(x, y) -> x ++ ": " ++ y ++ "\r\n") $ headers res
    hPutStr conn $ concat headers'
    hPutStr conn "\r\n"
    BS.hPutStr conn $ content res
-}

sendResponse :: Handle -> Response -> IO ()
sendResponse conn = do
    BS.hPut conn . bsFromResponse