diff --git a/Network/SCGI.hs b/Network/SCGI.hs --- a/Network/SCGI.hs +++ b/Network/SCGI.hs @@ -1,55 +1,66 @@ -- Copyright 2013 Chris Forno -module Network.SCGI (SCGIT, SCGI, runRequest, header, allHeaders, method, path, setHeader, Headers, Body, Status, Response(..)) where +module Network.SCGI (SCGIT, SCGI, runRequest, header, allHeaders, body, method, path, setHeader, responseHeader, Headers, Body, Status, Response(..), negotiate) where -import Control.Applicative ((<$>), (<*>), (<*)) +import Control.Applicative ((<$>), (<*>), (<*), (*>)) import Control.Arrow (first) +import Control.Exception (SomeException) import Control.Monad (liftM, liftM2) +import Control.Monad.CatchIO (MonadCatchIO(..)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, asks) -import Control.Monad.State (StateT, runStateT, MonadState, modify) +import Control.Monad.State (StateT, runStateT, MonadState, modify, gets) import Control.Monad.Trans.Class (MonadTrans, lift) -import Data.Attoparsec.ByteString.Char8 (Parser, IResult(..), parseOnly, parseWith, char, decimal, take, takeTill) -import Data.Attoparsec.Combinator (many1) +import Data.Attoparsec.ByteString.Char8 (Parser, IResult(..), parseOnly, parseWith, char, string, skipSpace, decimal, take, takeTill, inClass, rational) +import Data.Attoparsec.Combinator (many1, sepBy, option) 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.UTF8 as BLU 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 Data.Function (on) +import Data.List (sortBy, find, maximumBy) +import Data.Maybe (mapMaybe) +import qualified Data.Map.Lazy as M +import qualified System.FilePath.Glob as G import System.IO (Handle) import Prelude hiding (take) -type Headers = Map (CI B.ByteString) B.ByteString +type Headers = M.Map (CI B.ByteString) B.ByteString type Body = BL.ByteString type Status = BL.ByteString data Response = Response Status Body -newtype SCGIT m a = SCGIT (ReaderT Headers (StateT Headers m) a) - deriving (Monad, MonadState Headers, MonadReader Headers, MonadIO) +newtype SCGIT m a = SCGIT (ReaderT (Headers, Body) (StateT Headers m) a) + deriving (Monad, MonadState Headers, MonadReader (Headers, Body), MonadIO, MonadCatchIO) type SCGI = SCGIT IO instance MonadTrans SCGIT where lift = SCGIT . lift . lift -runSCGIT :: Monad m => Headers -> SCGIT m Response -> m (Response, Headers) -runSCGIT headers (SCGIT r) = runStateT (runReaderT r headers) M.empty +runSCGIT :: MonadIO m => Headers -> Body -> SCGIT m Response -> m (Response, Headers) +runSCGIT headers body' (SCGIT r) = runStateT (runReaderT r (headers, body')) M.empty --- |Lookup a request header. +-- |Look up a request header. header :: Monad m => B.ByteString -- ^ the header name (key) -> SCGIT m (Maybe B.ByteString) -- ^ the header value if found -header name = asks (M.lookup (CI.mk name)) +header name = asks (M.lookup (CI.mk name) . fst) -- |Return all request headers as a list in the format they were received from the web server. allHeaders :: Monad m => SCGIT m [(B.ByteString, B.ByteString)] -- ^ an association list of header: value pairs -allHeaders = asks (map (first CI.original) . M.toList) +allHeaders = asks (map (first CI.original) . M.toList . fst) +-- |Return the request body. +body :: Monad m + => SCGIT m (BL.ByteString) +body = asks snd + -- |Get the request method (GET, POST, etc.). You could look the header up -- yourself, but this normalizes the method name to uppercase. method :: Monad m => SCGIT m (Maybe B.ByteString) -- ^ the method if found @@ -71,10 +82,16 @@ -> SCGIT m () setHeader name value = modify (M.insert (CI.mk name) value) +-- |Look up a response header (one set during this request). This is useful when you need to check if a header has been set already (in case you want to modify it, for example). +responseHeader :: Monad m + => B.ByteString -- ^ the header name (key) + -> SCGIT m (Maybe B.ByteString) +responseHeader name = gets (M.lookup (CI.mk name)) + -- |Run a request in the SCGI monad. -runRequest :: MonadIO m +runRequest :: MonadCatchIO m => Handle -- ^ the handle connected to the web server (from 'accept') - -> (Body -> SCGIT m Response) -- ^ the action to run in the SCGI monad + -> SCGIT m Response -- ^ the action to run in the SCGI monad -> m () -- ^ 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. @@ -100,17 +117,20 @@ -- 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 <- liftIO $ (BL.fromChunks [rest] `BL.append`) `liftM` (if c > 0 then BL.hGet h c else return "") - (Response status body', headers') <- runSCGIT headerMap (f body) + body' <- liftIO $ (BL.fromChunks [rest] `BL.append`) `liftM` (if c > 0 then BL.hGet h c else return "") + (Response status body'', headers') <- catch (runSCGIT headerMap body' f) handleException -- Every SCGI response must include a status line first. liftIO $ BL.hPutStr h $ BL.concat ["Status: ", status, "\r\n"] -- Output the headers returned by the SCGI action. liftIO $ mapM_ (\(k, v) -> B.hPutStr h $ B.concat [CI.original k, ": ", v, "\r\n"]) $ M.toList headers' liftIO $ BL.hPutStr h "\r\n" -- Finally, output the body. - liftIO $ BL.hPutStr h body' + liftIO $ BL.hPutStr h body'' _ -> error "Failed to parse CONTENT_LENGTH." _ -> error "Failed to parse SCGI request." + where handleException :: MonadIO m => SomeException -> m (Response, Headers) + handleException e = return ( Response "500 Internal Server Error" (BLU.fromString $ show e) + , M.fromList [("Content-Type", "text/plain; charset=utf-8")] ) -- http://cr.yp.to/proto/netstrings.txt netstringParser :: Parser B.ByteString @@ -123,3 +143,53 @@ cStringParser :: Parser B.ByteString cStringParser = takeTill (== '\NUL') <* char '\NUL' + +negotiate :: Monad m => [B.ByteString] -> SCGIT m [B.ByteString] +negotiate representations = do + accept <- header "HTTP_ACCEPT" + case accept of + Nothing -> return representations + Just acc -> return $ best $ matches representations acc + +-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 +-- Available: text/html, text/plain +-- acceptParser = [("text/html", 1.0), ("application/xhtml+xml", 1.0), ("application/xml", 0.9), ("*/*", 0.8)] +-- matches = [("text/html", 1.0), ("text/plain", 0.8)] +-- best . matches = [(text/html, 1.0)] + +-- Accept: */* +-- Available: text/html, text/plain +-- acceptParser = [("*/*", 1.0)] +-- matches = [("text/html", 1.0), ("text/plain", 0.8)] +-- best . matches = [("text/html", 1.0), ("text/plain", 0.8)] + +type Quality = Double + +-- e.g. text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 +acceptParser :: Parser [(B.ByteString, Quality)] +acceptParser = ((,) <$> (skipSpace *> takeTill (inClass ";, ")) + <*> (option 1.0 (skipSpace *> char ';' *> skipSpace *> string "q=" *> rational))) + `sepBy` (skipSpace *> char ',' <* skipSpace) + +-- TODO: Is it possible for a representation to be returned more than once with different qualities? +-- | Find all representations that match the client's Accept header. +matches :: [B.ByteString] -- ^ the available representations for this resource + -> B.ByteString -- ^ the Accept header value from the client + -> [(B.ByteString, Quality)] -- ^ a associative list of matches as (representation, quality) pairs (where representation is a member of the list of available representations). +matches available accept = + case parseOnly acceptParser accept of + Left _ -> [] -- TODO: Log an error? + -- For now, only negotiate the content type. + Right acceptable -> mapMaybe (`match` ordered) available + where ordered = reverse $ sortBy (compare `on` snd) acceptable + match :: B.ByteString -> [(B.ByteString, Quality)] -> Maybe (B.ByteString, Quality) + match rep reps = case find (\(r, _) -> G.match (G.compile $ B8.unpack r) (B8.unpack rep)) reps of + Nothing -> Nothing + Just (_, q) -> Just (rep, q) + +-- | Find the best matches (all of the highest quality) from a list of resource representation matches. +best :: [(B.ByteString, Quality)] -- ^ a list of valid matches as (representation, quality) pairs + -> [B.ByteString] -- ^ the best matches from the list +best [] = [] +best ms = let highest = snd $ maximumBy (compare `on` snd) ms in + map fst [ x | x <- ms, snd x == highest ] diff --git a/sscgi.cabal b/sscgi.cabal --- a/sscgi.cabal +++ b/sscgi.cabal @@ -1,18 +1,18 @@ name: sscgi -version: 0.2.0 +version: 0.3.0 synopsis: Simple SCGI Library -description: This is a simple implementation of the SCGI protocol without support for the Network.CGI interface. +description: This is a simple implementation of the SCGI protocol without support for the Network.CGI interface. It's still rough but currently powers www.vocabulink.com and jekor.com. 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 +stability: beta category: Network build-type: Simple cabal-version: >=1.8 -tested-with: GHC == 7.4.1 +tested-with: GHC == 7.6.3 source-repository head type: git @@ -26,8 +26,11 @@ bytestring, case-insensitive, containers, + Glob, mtl, - transformers + MonadCatchIO-mtl, + transformers, + utf8-string extensions: GeneralizedNewtypeDeriving, OverloadedStrings ghc-options: -Wall -fno-warn-type-defaults