hascat-lib-0.2: Hascat/Protocol.hs

-----------------------------------------------------------------------------
-- |
-- orig-Module      :  Network.CGI.Protocol
-- Copyright   :  (c) Bjorn Bringert 2006
-- License     :  BSD-style
--
-- Maintainer  :  bjorn@bringert.net
-- Stability   :  experimental
-- Portability :  non-portable
--
-- An implementation of the program side of the CGI protocol.
--
-----------------------------------------------------------------------------

module Hascat.Protocol (
  Input(..), 
  ServletRequest(..),
  -- * Inputs
  decodeInput, takeInput,
  -- * URL encoding
  formDecode, urlDecode,
  -- * Utilities
  maybeRead, replace
 ) where

import Data.List (intersperse)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Network.URI
import qualified Network.HTTP as HTTP
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Hascat.Multipart



data ServletRequest  = ServletRequest  {
                    rqURI :: URI,
                    rqMethod :: HTTP.RequestMethod,
                    rqHeaders :: [HTTP.Header],
                    -- | Input parameters. For better laziness in reading inputs,
                    --   this is not a Map.
                    rqInputs :: [(String, Input)],
                    rqBody :: ByteString
}
               deriving Show

-- | The value of an input parameter, and some metadata.
data Input = Input {
                    inputValue :: ByteString,
                    inputFilename :: Maybe String,
                    inputContentType :: ContentType
                   }
              deriving Show

--
-- * Inputs
--



-- | Gets and decodes the input according to the request
--   method and the content-type.
decodeInput :: HTTP.Request ByteString
               ->  ServletRequest
decodeInput req@(HTTP.Request uri method headers inp) =
  let inputs = bodyInput req 
  in ServletRequest uri method headers (queryInput uri ++ inputs) inp



-- | Builds an 'Input' object for a simple value.
simpleInput :: String -> Input
simpleInput v = Input { inputValue = BS.pack v,
                        inputFilename = Nothing,
                        inputContentType = defaultInputType }

-- | The default content-type for variables.
defaultInputType :: ContentType
defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?

--
-- * Query string
--

-- | Gets inputs from the query string.
queryInput :: URI -- ^ 
           -> [(String,Input)] -- ^ Input variables and values.
queryInput uri = formInput $ 
   case uriQuery uri of
      '?':str -> str
      str     -> str

-- | Decodes application\/x-www-form-urlencoded inputs.
formInput :: String
          -> [(String,Input)] -- ^ Input variables and values.
formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]

--
-- * URL encoding
--


-- | Gets the name-value pairs from application\/x-www-form-urlencoded data.
formDecode :: String -> [(String,String)]
formDecode "" = []
formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
    where (nv,rs) = break (=='&') s
          (n,v) = break (=='=') nv

-- | Converts a single value from the 
--   application\/x-www-form-urlencoded encoding.
urlDecode :: String -> String
urlDecode = unEscapeString . replace '+' ' '

--
-- * Request content and form-data stuff
--

-- | Gets input variables from the body, if any.
bodyInput :: HTTP.Request ByteString
          -> [(String,Input)]
bodyInput req@(HTTP.Request uri method headers inp) =
   case method of
      HTTP.POST -> 
          let ctype = HTTP.lookupHeader HTTP.HdrContentType headers >>= parseContentType
           in decodeBody ctype $ takeInput headers inp
      _ -> []

-- | Decodes a POST body.
decodeBody :: Maybe ContentType
           -> ByteString
           -> [(String,Input)]
decodeBody ctype inp = 
    case ctype of
               Just (ContentType "application" "x-www-form-urlencoded" _) 
                   -> formInput (BS.unpack inp)
               Just (ContentType "multipart" "form-data" ps) 
                   -> multipartDecode ps inp
               Just _ -> [] -- unknown content-type, the user will have to
                            -- deal with it by looking at the raw content
               -- No content-type given, assume x-www-form-urlencoded
               Nothing -> formInput (BS.unpack inp)

-- | Takes the right number of bytes from the input.
takeInput :: [HTTP.Header]  -- ^ 
          -> ByteString         -- ^ Request body.
          -> ByteString         -- ^ CONTENT_LENGTH bytes from the request 
                                --   body, or the empty string if there is no
                                --   CONTENT_LENGTH.
takeInput headers req = 
    case len of
           Just l  -> BS.take l req
           Nothing -> BS.empty
     where len = HTTP.lookupHeader HTTP.HdrContentLength headers >>= maybeRead

-- | Decodes multipart\/form-data input.
multipartDecode :: [(String,String)] -- ^ Content-type parameters
                -> ByteString        -- ^ Request body
                -> [(String,Input)]  -- ^ Input variables and values.
multipartDecode ps inp =
    case lookup "boundary" ps of
         Just b -> let MultiPart bs = parseMultipartBody b inp
                    in map bodyPartToInput bs
         Nothing -> [] -- FIXME: report that there was no boundary

bodyPartToInput :: BodyPart -> (String,Input)
bodyPartToInput (BodyPart hs b) = 
    case getContentDisposition hs of
              Just (ContentDisposition "form-data" ps) -> 
                  (lookupOrNil "name" ps,
                   Input { inputValue = b,
                           inputFilename = lookup "filename" ps,
                           inputContentType = ctype })
              _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error
    where ctype = fromMaybe defaultInputType (getContentType hs)


--
-- * Utilities
--

-- | Replaces all instances of a value in a list by another value.
replace :: Eq a =>
           a   -- ^ Value to look for
        -> a   -- ^ Value to replace it with
        -> [a] -- ^ Input list
        -> [a] -- ^ Output list
replace x y = map (\z -> if z == x then y else z)

maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads

-- | Same as 'lookup' specialized to strings, but 
--   returns the empty string if lookup fails.
lookupOrNil :: String -> [(String,String)] -> String
lookupOrNil n = fromMaybe "" . lookup n