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,40 @@ +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/SnapServer.hs") + + + desc "test hello" + task "hello" $ do + sh "runghc test/hello.hs" + + desc "test ab" + task "ab" $ do + sh "runghc -isrc test/ab.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-snap-server.cabal b/hack2-handler-snap-server.cabal new file mode 100644 --- /dev/null +++ b/hack2-handler-snap-server.cabal @@ -0,0 +1,37 @@ +Name: hack2-handler-snap-server +Version: 2011.6.21 +Build-type: Simple +Synopsis: Hack2 Snap server handler +Description: Hack2 Snap server 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-snap-server +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 + , blaze-builder < 0.4 + , case-insensitive < 0.3 + , air + , snap-core + , snap-server + , directory + + hs-source-dirs: src/ + exposed-modules: + Hack2.Handler.SnapServer + 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 Snap server +----------------------------------------------------- + +* enumerator enabled, constant memory consumption when enumerator all the way down diff --git a/src/Hack2/Handler/SnapServer.hs b/src/Hack2/Handler/SnapServer.hs new file mode 100644 --- /dev/null +++ b/src/Hack2/Handler/SnapServer.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hack2.Handler.SnapServer +( + + run +, runWithConfig +, runWithSnapServerConfig +, ServerConfig(..) +, hackAppToSnap + +) where + +import Prelude () +import Air.Env hiding (def, Default) + +import Hack2 +import Data.Default (def, Default) +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 Snap.Types as Snap +import qualified Snap.Internal.Http.Types as SnapInternal + +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Map (toAscList, fromAscList) + +import Data.IORef (readIORef) +import qualified Snap.Http.Server as SnapServer + +import System.Directory (createDirectory, doesDirectoryExist) +import Control.Monad (when) + +{- + +{ 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 :: Snap.Request -> IO Env +requestToEnv request = do + (Snap.SomeEnumerator some_enumerator) <- readIORef - request.SnapInternal.rqBody + + return - def + + { + requestMethod = request.Snap.rqMethod.snapMethodToHackMethod + -- , scriptName = request.SnapInternal.rqSnapletPath + , pathInfo = B.append "/" - request.Snap.rqPathInfo + , queryString = request.Snap.rqQueryString -- .B.dropWhile (is '?') + , serverName = request.Snap.rqServerName + , serverPort = request.Snap.rqServerPort + , httpHeaders = request.SnapInternal.rqHeaders.toAscList.map_snd (listToMaybe > fromMaybe B.empty) .map caseInsensitiveHeaderToHeader + , hackUrlScheme = if request.Snap.rqIsSecure then HTTPS else HTTP + , hackInput = HackEnumerator some_enumerator + , hackHeaders = + [ + ("RemoteHost", request.Snap.rqRemoteAddr) + , ("RemotePort", request.Snap.rqRemotePort.show.pack) + ] + } + + +snapMethodToHackMethod :: Snap.Method -> RequestMethod +snapMethodToHackMethod Snap.GET = GET +snapMethodToHackMethod Snap.HEAD = HEAD +snapMethodToHackMethod Snap.POST = POST +snapMethodToHackMethod Snap.PUT = PUT +snapMethodToHackMethod Snap.DELETE = DELETE +snapMethodToHackMethod Snap.TRACE = TRACE +snapMethodToHackMethod Snap.OPTIONS = OPTIONS +snapMethodToHackMethod Snap.CONNECT = CONNECT + + +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) + +hackResponseToSnapResponse :: Response -> Snap.Response +hackResponseToSnapResponse response = + Snap.emptyResponse + . Snap.setResponseCode (response.status) + . (\r -> r { SnapInternal.rspHeaders = response.headers.map headerToCaseInsensitiveHeader. map_snd return .fromAscList }) + . Snap.setResponseBody (response.body.unHackEnumerator $= EL.map fromByteString) + + + +-- ($=) :: Monad m +-- => Enumerator ao m (Step ai m b) +-- -> Enumeratee ao ai m b +-- -> Enumerator ai m b +-- ($=) = joinE + + +hackAppToSnap :: Application -> Snap.Snap () +hackAppToSnap app = do + request <- Snap.getRequest + + env <- io - requestToEnv request + + response <- io - app env + + let snap_response = hackResponseToSnapResponse response + + Snap.putResponse snap_response + + + +data ServerConfig = ServerConfig + { + port :: Int + } + deriving (Show, Eq) + +instance Default ServerConfig where + def = ServerConfig + { + port = 3000 + } + + +runWithSnapServerConfig :: SnapServer.Config Snap.Snap a -> Application -> IO () +runWithSnapServerConfig snap_server_config app = do + let snap = hackAppToSnap app :: Snap.Snap () + + SnapServer.httpServe snap_server_config snap + + +runWithConfig :: ServerConfig -> Application -> IO () +runWithConfig config app = do + let snap_config = SnapServer.emptyConfig.SnapServer.setPort (config.port) + + snap_default_log_path = "log" + + log_directory_exist <- doesDirectoryExist snap_default_log_path + when (not - log_directory_exist) - + createDirectory snap_default_log_path + + + runWithSnapServerConfig snap_config app + + +run :: Application -> IO () +run = runWithConfig def +