packages feed

hack2-handler-happstack-server (empty) → 2011.6.10

raw patch · 7 files changed

+258/−0 lines, 7 filesdep +basedep +bytestringdep +cgisetup-changed

Dependencies added: base, bytestring, cgi, containers, data-default, hack2, happstack-server, mtl, network

Files

+ 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,34 @@+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/HappstackServer.hs")++  desc "test"+  task "test" $ do+    sh "runghc -isrc src/Test.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
@@ -0,0 +1,4 @@+2011.6.10+----------++* init
+ hack2-handler-happstack-server.cabal view
@@ -0,0 +1,22 @@+Name:                 hack2-handler-happstack-server+Version:              2011.6.10+Build-type:           Simple+Synopsis:             Hack2 Happstack server handler+Description:          Hack2 Happstack 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:             http://github.com/nfjinjing/hack2-handler-happstack-server+data-files:           readme.md, changelog.md, Nemesis++library+  ghc-options: -Wall+  build-depends: base >= 4.0 && < 5, cgi, network, bytestring, data-default >= 0.2, hack2 >= 2011.6.10, happstack-server < 6, containers, mtl+  hs-source-dirs: src/+  exposed-modules:  +                    Hack2.Handler.HappstackServer+
+ readme.md view
@@ -0,0 +1,9 @@+Happstack server handler+-----------------++* preferred for production++Known issues+------------++* The backend does not distinguish between `http://example/abc/` and `http://example/abc`, (notice the absence of trailing slash).
+ src/Hack2/Handler/HappstackServer.hs view
@@ -0,0 +1,154 @@+-- code structure written by John MacFarlane, +-- I filled in some missing pieces and make it compile.++{-# LANGUAGE PackageImports #-}+{-# LANGUAGE OverloadedStrings #-}+++module Hack2.Handler.HappstackServer (run, runWithConfig, ServerConf(..), appToServerPart) where+++import Control.Arrow ((>>>))+import "mtl" Control.Monad.State+import Data.Char+import Data.Default+import Data.List+import Data.Maybe+import qualified Hack2 as Hack2+import Happstack.Server.SimpleHTTP as Happstack hiding (port, escape)+import Network.URI (escapeURIString, isAllowedInURI)+import Control.Applicative++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++import qualified Data.Map as M+import qualified Happstack.Server.SimpleHTTP as H++data ServerConf = ServerConf { port :: Int, serverName :: L.ByteString }+  deriving (Show)++instance Default ServerConf where+  def = ServerConf { port = 3000, serverName = "localhost"}++runWithConfig :: ServerConf -> Hack2.Application -> IO ()+runWithConfig conf = simpleHTTP nullConf { H.port = port conf } . appToServerPart conf++run :: Hack2.Application -> IO ()+run = runWithConfig def++appToServerPart :: ServerConf -> Hack2.Application -> ServerPart (Happstack.Response)+appToServerPart conf app = askRq >>= liftIO . (hackRToServerPartR <$>) . app . reqToEnv+  where+    reqToEnv req =+      def+        { Hack2.requestMethod   = convertRequestMethod $ rqMethod req+        , Hack2.scriptName      = L.empty+        , Hack2.pathInfo        = L.pack $ escape $ "/" ++ (intercalate "/" $ rqPaths req)+        , Hack2.queryString     = L.pack $ escape $ dropWhile (== '?') $ rqQuery req+        , Hack2.serverName      = serverName conf+        , Hack2.serverPort      = (snd $ rqPeer req)+        , Hack2.httpHeaders     = headersToHttp (rqHeaders req)+        , Hack2.hackInput       = (\(Body x) -> x) (rqBody req)+        , Hack2.hackHeaders     = [("RemoteHost", L.pack $ fst $ rqPeer req)]+        }+    +    escape = escapeURIString isAllowedInURI+    +    convertRequestMethod Happstack.OPTIONS     =     Hack2.OPTIONS+    convertRequestMethod Happstack.GET         =     Hack2.GET+    convertRequestMethod Happstack.HEAD        =     Hack2.HEAD+    convertRequestMethod Happstack.POST        =     Hack2.POST+    convertRequestMethod Happstack.PUT         =     Hack2.PUT+    convertRequestMethod Happstack.DELETE      =     Hack2.DELETE+    convertRequestMethod Happstack.TRACE       =     Hack2.TRACE+    convertRequestMethod Happstack.CONNECT     =     Hack2.CONNECT+    ++headersToHttp :: Headers -> [(L.ByteString, L.ByteString)]+headersToHttp = M.toList >>> map snd >>> map headerToPair+  where+    headerToPair (HeaderPair k v) = +      (L.pack $ normalizeHeader $ S.unpack k, s2l $ S.intercalate " " v)++hackRToServerPartR :: Hack2.Response -> Happstack.Response+hackRToServerPartR r = Happstack.Response +  { rsCode      = Hack2.status r+  , rsHeaders   = httpToHeaders $ Hack2.headers r+  , rsFlags     = RsFlags {rsfContentLength = False}+  , rsBody      = Hack2.body r+  , rsValidator = Nothing +  }++l2s :: L.ByteString -> S.ByteString+l2s = S.concat . L.toChunks++s2l :: S.ByteString -> L.ByteString+s2l = L.fromChunks . return++httpToHeaders :: [(L.ByteString, L.ByteString)] -> Headers+httpToHeaders = map pairToHeader >>> M.fromList+  where +    pairToHeader (k,v) = +      ((S.pack $ map toLower $ L.unpack k), HeaderPair (l2s k) [l2s v])+++-- happstack converts all request header to lowercase ...+-- so we need to convert it back ...+normalizeHeader :: String -> String+normalizeHeader s = fromMaybe s $ find (map toLower >>> (== s) ) headerList++headerList :: [String]+headerList = +  [ "Cache-Control"        +  , "Connection"           +  , "Date"                 +  , "Pragma"               +  , "Transfer-Encoding"    +  , "Upgrade"              +  , "Via"                  +  , "Accept"               +  , "Accept-Charset"       +  , "Accept-Encoding"      +  , "Accept-Language"      +  , "Authorization"        +  , "Cookie"               +  , "Expect"               +  , "From"                 +  , "Host"                 +  , "If-Modified-Since"    +  , "If-Match"             +  , "If-None-Match"        +  , "If-Range"             +  , "If-Unmodified-Since"  +  , "Max-Forwards"         +  , "Proxy-Authorization"  +  , "Range"                +  , "Referer"              +  , "User-Agent"           +  , "Age"                  +  , "Location"             +  , "Proxy-Authenticate"   +  , "Public"               +  , "Retry-After"          +  , "Server"               +  , "Set-Cookie"           +  , "TE"                   +  , "Trailer"              +  , "Vary"                 +  , "Warning"              +  , "WWW-Authenticate"     +  , "Allow"                +  , "Content-Base"         +  , "Content-Encoding"     +  , "Content-Language"     +  , "Content-Length"       +  , "Content-Location"     +  , "Content-MD5"          +  , "Content-Range"        +  , "Content-Type"         +  , "ETag"                 +  , "Expires"              +  , "Last-Modified"        +  , "Content-Transfer-Encodeing"+  ]