hack2-handler-snap-server (empty) → 2011.6.21

raw patch · 7 files changed

+282/−0 lines, 7 filesdep +airdep +basedep +blaze-buildersetup-changed

Dependencies added: air, base, blaze-builder, bytestring, case-insensitive, containers, data-default, directory, enumerator, hack2, mtl, network, snap-core, snap-server

Files

LICENSE +31/−0
Nemesis +40/−0
Setup.lhs +4/−0
changelog.md +0/−0
hack2-handler-snap-server.cabal +37/−0
readme.md +4/−0
src/Hack2/Handler/SnapServer.hs +166/−0

+ LICENSE view

@@ -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.

+ Nemesis view

@@ -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"

+ Setup.lhs view

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

+ changelog.md view

+ hack2-handler-snap-server.cabal view

@@ -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 <nfjinjing@gmail.com>+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+

+ readme.md view

@@ -0,0 +1,4 @@+Serving Hack2 application with the great Snap server+-----------------------------------------------------++* enumerator enabled, constant memory consumption when enumerator all the way down

+ src/Hack2/Handler/SnapServer.hs view

@@ -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+