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,36 @@ +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/Interface/Wai.hs") + + + desc "start hello" + task "hello" - do + sh "runghc -isrc test/hello.hs" + + + desc "start small app (using wai-devel)" + task "small-app" - do + sh "cd test; runghc -i../src runSmallApp.hs" 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-interface-wai.cabal b/hack2-interface-wai.cabal new file mode 100644 --- /dev/null +++ b/hack2-interface-wai.cabal @@ -0,0 +1,37 @@ +Name: hack2-interface-wai +Version: 2012.5.24 +Build-type: Simple +Synopsis: Hack2 interface of WAI +Description: Hack2 interface of WAI +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-interface-wai +data-files: readme.md, changelog.md, Nemesis + +library + + build-depends: + base >= 4.0 && <= 100 + , network + , bytestring + , data-default >= 0.2 + , hack2 >= 2011.6.20 + , containers + , mtl + , enumerator + , wai + , blaze-builder + , http-types + , case-insensitive + , air + , safe + + hs-source-dirs: src/ + exposed-modules: + Hack2.Interface.Wai + diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,23 @@ +Interfacing Hack2 and Wai + + +Example: `test/hello` + + {-# LANGUAGE OverloadedStrings #-} + + import Hack2 + import Hack2.Interface.Wai (hackAppToWaiApp) + import Data.Default (def) + import Network.Wai.Handler.Warp (run) + + app :: Application + app = \env -> + return $ + Response 200 [ ("Content-Type", "text/plain") ] "Hello World (Hack2 to Wai)" + + + main :: IO () + main = do + putStrLn $ "http://localhost:3000/" + run 3000 (hackAppToWaiApp app) + diff --git a/src/Hack2/Interface/Wai.hs b/src/Hack2/Interface/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Hack2/Interface/Wai.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hack2.Interface.Wai +( + 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 qualified Data.ByteString.Lazy.Char8 as Lazy + +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 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 502 = HTTPTypes.status502 +statusToStatusHeader 503 = HTTPTypes.status503 +statusToStatusHeader 504 = HTTPTypes.status504 +statusToStatusHeader 505 = HTTPTypes.status505 +statusToStatusHeader _ = HTTPTypes.status505 + +hackAppToWaiApp :: Application -> Wai.Application +hackAppToWaiApp app request = do + response <- io - app - requestToEnv request + + let wai_response = hackResponseToWaiResponse response + + return - wai_response + + + + +hackResponseToWaiResponse :: Response -> Wai.Response +hackResponseToWaiResponse response = + let s = response.status.statusToStatusHeader + h = response.headers.map headerToCaseInsensitiveHeader + + b = Lazy.fromChunks [response.body] + + in + + Wai.responseLBS s h b + +