diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Chris Forno (jekor) + +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 Chris Forno (jekor) 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/Network/SCGI.hs b/Network/SCGI.hs new file mode 100644 --- /dev/null +++ b/Network/SCGI.hs @@ -0,0 +1,116 @@ +-- Copyright 2013 Chris Forno + +module Network.SCGI (SCGI, runRequest, header, allHeaders, method, path, setHeader, Headers, Body, Status, Response(..)) where + +import Control.Applicative ((<$>), (<*>), (<*)) +import Control.Arrow (first) +import Control.Monad (liftM, liftM2) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, asks) +import Control.Monad.State (StateT, runStateT, MonadState, modify) +import Data.Attoparsec.ByteString.Char8 (Parser, IResult(..), parseOnly, parseWith, char, decimal, take, takeTill) +import Data.Attoparsec.Combinator (many1) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 () +import Data.Char (toUpper) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Map (Map) +import qualified Data.Map as M +import System.IO (Handle) + +import Prelude hiding (take) + +type Headers = Map (CI B.ByteString) B.ByteString +type Body = BL.ByteString +type Status = BL.ByteString +data Response = Response Status Body + +newtype SCGI a = SCGI (ReaderT Headers (StateT Headers IO) a) + deriving (Functor, Monad, MonadIO, MonadState Headers, MonadReader Headers) + +runSCGI :: Headers -> SCGI Response -> IO (Response, Headers) +runSCGI headers (SCGI r) = runStateT (runReaderT r headers) M.empty + +-- |Lookup a request header. +header :: B.ByteString -- ^ the header name (key) + -> SCGI (Maybe B.ByteString) -- ^ the header value if found +header name = asks (M.lookup (CI.mk name)) + +-- |Return all request headers as a list in the format they were received from the web server. +allHeaders :: SCGI [(B.ByteString, B.ByteString)] -- ^ an association list of header: value pairs +allHeaders = asks (map (first CI.original) . M.toList) + +-- |Get the request method (GET, POST, etc.). You could look the header up +-- yourself, but this normalizes the method name to uppercase. +method :: SCGI (Maybe B.ByteString) -- ^ the method if found +method = liftM (B8.map toUpper) `liftM` header "REQUEST_METHOD" + +-- |Get the requested path. According to the spec, this can be complex, and +-- actual CGI implementations diverge from the spec. I've found this to work, +-- even though it doesn't seem correct or intuitive. +path :: SCGI (Maybe B.ByteString) -- ^ the path if found +path = do + path1 <- header "SCRIPT_NAME" + path2 <- header "PATH_INFO" + return $ liftM2 B.append path1 path2 + +-- |Set a response header. +setHeader :: B.ByteString -- ^ the header name (key) + -> B.ByteString -- ^ the header value + -> SCGI () +setHeader name value = modify (M.insert (CI.mk name) value) + +-- |Run a request in the SCGI monad. +runRequest :: Handle -- ^ the handle connected to the web server (from 'accept') + -> (Body -> SCGI Response) -- ^ the action to run in the SCGI monad + -> IO () -- ^ nothing is returned, the result of the action is written back to the server +runRequest h f = do + -- Note: This could potentially read any amount of data into memory. + -- For now, I'm leaving it up to the SCGI implementation in the server to block large header payloads. + -- + -- First, parse the netstring containing the headers. If we tried to avoid this step the syntax for + -- the headers would be ambiguous. + result <- parseWith (B.hGetSome h 4096) netstringParser "" + case result of + Done rest headerString -> + case parseOnly (many1 headerParser) headerString of + Left e -> error e + Right headers -> do + -- CONTENT_LENGTH is required by the SCGI spec. Without it, we + -- wouldn't know when we'd reached the end of the request. + -- + -- The header Map uses case-insensitive keys. + let headerMap = M.fromList $ map (first CI.mk) headers + len' = B8.readInt $ M.findWithDefault (error "CONTENT_LENGTH missing from request") "CONTENT_LENGTH" headerMap + case len' of + Just (len, _) -> do + -- We have probably read past the end of the header. Take the + -- rest of the unparsed string and what remains to be read + -- (determined from the CONTENT_LENGTH) and make that the body. + let c = fromIntegral (len - B.length rest) + body <- (BL.fromChunks [rest] `BL.append`) `liftM` (if c > 0 then BL.hGet h c else return "") + (Response status body', headers') <- runSCGI headerMap (f body) + -- Every SCGI response must include a status line first. + BL.hPutStr h $ BL.concat ["Status: ", status, "\r\n"] + -- Output the headers returned by the SCGI action. + mapM_ (\(k, v) -> B.hPutStr h $ B.concat [CI.original k, ": ", v, "\r\n"]) $ M.toList headers' + BL.hPutStr h "\r\n" + -- Finally, output the body. + BL.hPutStr h body' + _ -> error "Failed to parse CONTENT_LENGTH." + _ -> error "Failed to parse SCGI request." + +-- http://cr.yp.to/proto/netstrings.txt +netstringParser :: Parser B.ByteString +netstringParser = do + count <- decimal <* char ':' + take count <* char ',' + +headerParser :: Parser (B.ByteString, B.ByteString) +headerParser = (,) <$> cStringParser <*> cStringParser + +cStringParser :: Parser B.ByteString +cStringParser = takeTill (== '\NUL') <* char '\NUL' diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sscgi.cabal b/sscgi.cabal new file mode 100644 --- /dev/null +++ b/sscgi.cabal @@ -0,0 +1,33 @@ +name: sscgi +version: 0.1.0 +synopsis: Simple SCGI Library +description: This is a simple implementation of the SCGI protocol without support for the Network.CGI interface. +homepage: https://github.com/jekor/haskell-sscgi +bug-reports: https://github.com/jekor/haskell-sscgi/issues +license: BSD3 +license-file: LICENSE +author: Chris Forno (jekor) +maintainer: jekor@jekor.com +stability: alpha +category: Network +build-type: Simple +cabal-version: >=1.8 +tested-with: GHC == 7.4.1 + +source-repository head + type: git + location: git://github.com/jekor/haskell-sscgi.git + +library + exposed-modules: Network.SCGI + -- other-modules: + build-depends: base >= 4 && < 6, + attoparsec, + bytestring, + case-insensitive, + containers, + mtl, + transformers + extensions: GeneralizedNewtypeDeriving, + OverloadedStrings + ghc-options: -Wall -fno-warn-type-defaults