diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2011, Jinjing Wang + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jinjing Wang nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Nemesis b/Nemesis new file mode 100644 --- /dev/null +++ b/Nemesis @@ -0,0 +1,35 @@ +nemesis = do + + clean + [ "**/*.hi" + , "**/*.o" + , "manifest" + , "main" + , "nemesis-tmp.*" + , "Test" + ] + + + desc "prepare cabal dist" + task "dist" $ do + sh "cabal clean" + sh "cabal configure" + sh "cabal sdist" + + + desc "put all .hs files in manifest" + task "manifest" $ do + sh "find . | grep 'hs$' > manifest" + + + desc "start console" + task "i" (sh "ghci -isrc src/Hack2/Handler/Warp.hs") + + + desc "test" + task "test" $ do + sh "runghc test.hs" + + desc "show sloc" + task "stat" $ do + sh "cloc -match-f=hs$ --quiet src" diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/hack2-handler-warp.cabal b/hack2-handler-warp.cabal new file mode 100644 --- /dev/null +++ b/hack2-handler-warp.cabal @@ -0,0 +1,38 @@ +Name: hack2-handler-warp +Version: 2011.6.20 +Build-type: Simple +Synopsis: Hack2 warp handler +Description: Hack2 warp handler +License: BSD3 +License-file: LICENSE +Author: Jinjing Wang +Maintainer: Jinjing Wang +Build-Depends: base +Cabal-version: >= 1.2 +category: Web +homepage: https://github.com/nfjinjing/hack2-handler-warp +data-files: readme.md, changelog.md, Nemesis + +library + + build-depends: + base >= 4.0 && < 5 + , network + , bytestring + , data-default >= 0.2 + , hack2 >= 2011.6.20 + , containers + , mtl + , enumerator < 5 + , wai < 0.5 + , warp < 0.5 + , blaze-builder < 0.4 + , http-types < 0.7 + , case-insensitive < 0.3 + , air + , safe + + hs-source-dirs: src/ + exposed-modules: + Hack2.Handler.Warp + diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,4 @@ +Serving Hack2 application with the great Warp server +----------------------------------------------------- + +* enumerator enabled, constant memory consumption when enumerator all the way down diff --git a/src/Hack2/Handler/Warp.hs b/src/Hack2/Handler/Warp.hs new file mode 100644 --- /dev/null +++ b/src/Hack2/Handler/Warp.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 + +{- + +{ 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 + , 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 +