module Hack2.Handler.Warp
(
run
, runWithConfig
, 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 Data.Enumerator (Enumerator, Iteratee (..), ($$), joinI, run_)
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
requestToEnv :: Wai.Request -> Env
requestToEnv request = def
{
requestMethod = request.Wai.requestMethod.show.upper.Safe.readDef GET
, pathInfo = request.Wai.rawPathInfo
, queryString = request.Wai.rawQueryString
, 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 = hackResponseToWaiResponseEnumerator response
return Wai.ResponseEnumerator wai_response
hackResponseToWaiResponseEnumerator :: Response -> (forall a. Wai.ResponseEnumerator a)
hackResponseToWaiResponseEnumerator response f =
let s = response.status.statusToStatusHeader
h = response.headers.map headerToCaseInsensitiveHeader
in
run_ response.body.unHackEnumerator $$ joinI EL.map fromByteString $$ f s h
data ServerConfig = ServerConfig
{
port :: Int
}
deriving (Show, Eq)
instance Default ServerConfig where
def = ServerConfig
{
port = 3000
}
runWithConfig :: ServerConfig -> Application -> IO ()
runWithConfig config app = Warp.runSettings
Warp.defaultSettings {Warp.settingsPort = config.port}
(hackAppToWaiApp app)
run :: Application -> IO ()
run = runWithConfig def