Warp.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hack2.Handler.Warp 
(

  run
, runWithConfig
, runWithWarpSettings
, ServerConfig(..)
, hackAppToWaiApp

) where

import Prelude ()
import Air.Env hiding (def, Default)

import qualified Network.Wai as Wai
import Hack2
import Data.Default (def, Default)
import qualified Network.HTTP.Types as HTTPTypes
import qualified Data.CaseInsensitive as CaseInsensitive
import Data.ByteString.Char8 (ByteString, pack)
import qualified Data.ByteString.Char8 as B
import Data.Enumerator (Enumerator, Iteratee (..), ($$), joinI, run_, Enumeratee, Step, (=$))
import qualified Data.Enumerator.List as EL
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)

import qualified Network.Wai.Handler.Warp as Warp
import qualified Safe as Safe

{-

{  requestMethod  :: RequestMethod
,  scriptName     :: ByteString
,  pathInfo       :: ByteString
,  queryString    :: ByteString
,  serverName     :: ByteString
,  serverPort     :: Int
,  httpHeaders    :: [(ByteString, ByteString)]
,  hackVersion    :: (Int, Int, Int)
,  hackUrlScheme  :: HackUrlScheme
,  hackInput      :: HackEnumerator
,  hackErrors     :: HackErrors
,  hackHeaders    :: [(ByteString, ByteString)]

-}
requestToEnv :: Wai.Request -> Env
requestToEnv request = def
  {
    requestMethod  = request.Wai.requestMethod.show.upper.Safe.readDef GET
  , pathInfo       = request.Wai.rawPathInfo 
  , queryString    = request.Wai.rawQueryString.B.dropWhile (is '?')
  , serverName     = request.Wai.serverName
  , serverPort     = request.Wai.serverPort
  , httpHeaders    = request.Wai.requestHeaders.map caseInsensitiveHeaderToHeader
  , hackUrlScheme  = if request.Wai.isSecure then HTTPS else HTTP
  , hackHeaders    = [("RemoteHost", request.Wai.remoteHost.show.pack)]
  }
  

caseInsensitiveHeaderToHeader :: (CaseInsensitive.CI ByteString, ByteString) -> (ByteString, ByteString)
caseInsensitiveHeaderToHeader (x, y) = (x.CaseInsensitive.original, y) 

headerToCaseInsensitiveHeader ::  (ByteString, ByteString) -> (CaseInsensitive.CI ByteString, ByteString)
headerToCaseInsensitiveHeader (x, y) = (x.CaseInsensitive.mk, y) 

statusToStatusHeader :: Int -> HTTPTypes.Status
statusToStatusHeader 200 = HTTPTypes.status200
statusToStatusHeader 201 = HTTPTypes.status201
statusToStatusHeader 206 = HTTPTypes.status206
statusToStatusHeader 301 = HTTPTypes.status301
statusToStatusHeader 302 = HTTPTypes.status302
statusToStatusHeader 303 = HTTPTypes.status303
statusToStatusHeader 304 = HTTPTypes.status304
statusToStatusHeader 400 = HTTPTypes.status400
statusToStatusHeader 401 = HTTPTypes.status401
statusToStatusHeader 403 = HTTPTypes.status403
statusToStatusHeader 404 = HTTPTypes.status404
statusToStatusHeader 405 = HTTPTypes.status405
statusToStatusHeader 412 = HTTPTypes.status412
statusToStatusHeader 416 = HTTPTypes.status416
statusToStatusHeader 500 = HTTPTypes.status500
statusToStatusHeader 501 = HTTPTypes.status501
statusToStatusHeader _   = HTTPTypes.statusNotImplemented

hackAppToWaiApp :: Application -> Wai.Application
hackAppToWaiApp app request = do
   response <- io - app - requestToEnv request
   
   let wai_response_enumerator = hackResponseToWaiResponseEnumerator response 
   
   return - Wai.ResponseEnumerator wai_response_enumerator
   
  
  

hackResponseToWaiResponseEnumerator :: (forall a. Response -> Wai.ResponseEnumerator a)
hackResponseToWaiResponseEnumerator response f = 
  let s = response.status.statusToStatusHeader
      h = response.headers.map headerToCaseInsensitiveHeader
  
      -- wai response enumerator expect the callback (iteratee) to acts on builder.
      -- type ResponseEnumerator a =
      --  (H.Status -> H.ResponseHeaders -> Iteratee Builder IO a) -> IO a
  
      server_iteratee :: Iteratee Builder IO a
      server_iteratee = f s h

      
      -- in Builder, fromByteString :: S.ByteString -> Builder
      -- in Enumerator.List, map :: Monad m => (ao -> ai)
      --  -> Enumeratee ao ai m b
      
      -- type Enumeratee ao ai m b = Step ai m b -> Iteratee ao m (Step ai m b)
      -- builder_enumeratee :: Enumeratee ByteString Builder IO a
      builder_enumeratee :: Step Builder IO a -> Iteratee ByteString IO (Step Builder IO a)
      builder_enumeratee = EL.map fromByteString
      
      
      {-
      -- make fromByteString act as the preprocesser of server_iteratee,
      -- by joining
      -- ($$) :: Monad m
      --      => (Step a m b -> Iteratee a' m b')
      --      -> Iteratee a m b
      --      -> Iteratee a' m b'
      -- ($$) = (==<<)
      -- this is similar to :: readFile >>= putStrLn, in a Monad context
      bytestring_to_builder_layered_iteratee :: Iteratee ByteString IO (Step Builder IO a)
      bytestring_to_builder_layered_iteratee = builder_enumeratee $$ server_iteratee
      
      -- iteratee is needs to be flattened
      -- joinI :: Monad m => Iteratee a m (Step a' m b)
      --       -> Iteratee a m b
      -- joinI outer = outer >>= check where
      --  check (Continue k) = k EOF >>== \s -> case s of
      --    Continue _ -> error "joinI: divergent iteratee"
      --    _ -> check s
      --  check (Yield x _) = return x
      --  check (Error e) = throwError e
      
      flattened_server_iteratee :: Iteratee ByteString IO a
      flattened_server_iteratee = joinI bytestring_to_builder_layered_iteratee
      -}
      
      flattened_server_iteratee :: Iteratee ByteString IO a
      flattened_server_iteratee =  builder_enumeratee =$ server_iteratee
      
      final_iteratee_taking_input_from_hack_enumerator :: Iteratee ByteString IO a
      final_iteratee_taking_input_from_hack_enumerator = response.body.unHackEnumerator $$ flattened_server_iteratee
      
      
  in
  run_ final_iteratee_taking_input_from_hack_enumerator


data ServerConfig = ServerConfig
  {
    port :: Int
  }
  deriving (Show, Eq)

instance Default ServerConfig where
  def = ServerConfig
    {
      port = 3000
    }

runWithWarpSettings :: Warp.Settings -> Application -> IO ()
runWithWarpSettings setting app = do
  Warp.runSettings setting (hackAppToWaiApp app)

runWithConfig :: ServerConfig -> Application -> IO ()
runWithConfig config app = 
  let setting = Warp.defaultSettings {Warp.settingsPort = config.port}
  in
  runWithWarpSettings setting app
  

run :: Application -> IO ()
run = runWithConfig def