{-# LANGUAGE CPP #-}

module Httpd
    ( Request, Response, Server
    , mkResponse
    , reqMethod, reqURI, reqHeaders, reqBody
    , shed
#ifdef WARP_TESTS
    , warp
#endif
    )
    where

import Control.Applicative
import Control.Arrow ( (***) )
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans ( liftIO )
import qualified Data.ByteString            as B
import qualified Data.ByteString.Lazy       as BL
import qualified Data.ByteString.Char8      as BC
import qualified Data.ByteString.Lazy.Char8 as BLC
#ifdef WARP_TESTS
import qualified Data.CaseInsensitive       as CI
#endif
import Data.Maybe ( fromJust )
import Network.URI ( URI, parseRelativeReference )

import Network.Socket
    ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily
      , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6)
      , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr)
    )
#ifdef WARP_TESTS
#if MIN_VERSION_network(2,4,0)
import Network.Socket ( bind )
#else
import Network.Socket ( bindSocket, Socket, SockAddr )
#endif
#endif

import qualified Network.Shed.Httpd as Shed
    ( Request, Response(Response), initServer
    , reqMethod, reqURI, reqHeaders, reqBody
    )
#ifdef WARP_TESTS
#if !MIN_VERSION_wai(3,0,0)
import qualified Data.Conduit.Lazy as Warp
#endif

import qualified Network.HTTP.Types as Warp
    ( Status(..) )
import qualified Network.Wai as Warp
import qualified Network.Wai.Handler.Warp as Warp
    ( runSettingsSocket, defaultSettings, setPort )
#endif

data Request = Request
    {
     reqMethod :: String,
     reqURI :: URI,
     reqHeaders :: [(String, String)],
     reqBody :: String
    }

data Response = Response
    {
     respStatus :: Int,
     respHeaders :: [(String, String)],
     respBody :: String
    }

mkResponse :: Int -> [(String, String)] -> String -> Response
mkResponse = Response

type Server = Int -> (Request -> IO Response) -> IO ()

shed :: Server
shed port handler =
    () <$ Shed.initServer
           port
           (liftM responseToShed . handler . requestFromShed)
  where
     responseToShed (Response status hdrs body) =
         Shed.Response status hdrs body
     chomp = reverse . strip '\r' . reverse
     strip c (c':str) | c == c' = str
     strip c str = str
     requestFromShed request =
         Request
         {
          reqMethod = Shed.reqMethod request,
          reqURI = Shed.reqURI request,
          reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,
          reqBody = Shed.reqBody request
         }

#if !MIN_VERSION_bytestring(0,10,0)
instance NFData B.ByteString where
   rnf = rnf . B.length
#endif

#ifdef WARP_TESTS
#if !MIN_VERSION_network(2,4,0)
bind :: Socket -> SockAddr -> IO ()
bind = bindSocket
#endif

warp :: Bool -> Server
warp ipv6 port handler = do
    addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream })
                             (Just $ if ipv6 then "::1" else "127.0.0.1")
                             (Just . show $ port)
    case addrinfos of
        [] -> fail "Couldn't obtain address information in warp"
        (addri:_) -> do
            sock <- socket (addrFamily addri) Stream defaultProtocol
            setSocketOption sock ReuseAddr 1
            bind sock (addrAddress addri)
            listen sock 5
#if MIN_VERSION_wai(3,0,0)
            Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do
               request <- requestFromWarp warpRequest
               response <- handler request
               warpRespond (responseToWarp response)
#else
            Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do
               request <- requestFromWarp warpRequest
               response <- handler request
               return (responseToWarp response)
#endif
  where
     responseToWarp (Response status hdrs body) =
         Warp.responseLBS
                 (Warp.Status status B.empty)
                 (map headerToWarp hdrs)
                 (BLC.pack body)
     headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)
     headerFromWarp (name, value) =
         (BC.unpack (CI.original name), BC.unpack value)
     requestFromWarp request = do
#if MIN_VERSION_wai(3,0,1)
         body <- fmap BLC.unpack $ Warp.strictRequestBody request
#else
         body <- fmap BLC.unpack $ Warp.lazyRequestBody request
         body `deepseq` return ()
#endif
         return $
                Request
                {
                 reqMethod = BC.unpack (Warp.requestMethod request),
                 reqURI = fromJust . parseRelativeReference .
                          BC.unpack . Warp.rawPathInfo $
                          request,
                 reqHeaders = map headerFromWarp (Warp.requestHeaders request),
                 reqBody = body
                }
#endif