hsp-0.2: HTTP/Request.hs

{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HTTP.Request
-- Copyright   :  (c) Andreas Farre, Niklas Broberg, 2004
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Andreas Farre, d00farre@dtek.chalmers.se,
--		  Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability   :  experimental
-- Portability :  portable
--
-- Datatypes representing the concept of an HTTP request.
-----------------------------------------------------------------------------
module HTTP.Request (
	-- * Datatypes
	  Request(..)
	, Method(..)
	, RequestURI(..)
	, HTTPVersion(..)
	, Header(..)
	, MessageBody(..)

	-- * Parsing
	, parseRequest		-- :: String -> Maybe Request
	) where

import Data.Char ( isDigit )

import Data.List ( isPrefixOf )
import Network.URI

import HTTP.Common
import HTTP.Util

-------------------------------------------------------
-- Datatypes

-- | An HTTP request
data Request
   = Request {
              reqMethod      :: Method,
              reqURI         :: RequestURI,
              reqVersion     :: HTTPVersion,
              reqHeaders     :: [Header],
	      reqMessageBody :: MessageBody
             }

instance Show Request where
    showsPrec n req = -- parensIf (n > 0) $
    	shows (reqMethod req) .
	showsSpace .
	shows (reqURI req) .
	showsSpace .
	shows (reqVersion req) .
	showsCRLF .
	shows (reqHeaders req) .
	shows (reqMessageBody req)
{-
      where parensIf b s =
      		if b then showChar '(' . s . showChar ')'
      		     else s
-}

data Method
    = OPTIONS
    | GET
    | HEAD
    | POST
    | PUT
    | DELETE
    | TRACE
    | CONNECT
    | ExtensionMethod String
  deriving (Eq, Show, Read)

data RequestURI
    = NoURI
    | AbsURI URI
    | AbsPath FilePath

instance Show RequestURI where
    show NoURI = "*"
    show (AbsURI uri) = show uri
    show (AbsPath path) = path


-------------------------------------------------------
-- Parsing requests in string format

parseRequest :: String -> Maybe Request
parseRequest str =
     case crlines $ killLWS str of
       (rqline:hdrstrs) ->
        case words rqline of
	 [m, u, v] ->
	  let muri = parseRURI u
	      mver = parseVersion v
	      mhds = parseHeaders hdrstrs
	   in case (muri, mver, mhds) of
		(Just uri, Just ver, Just hds) ->
			Just $ Request
				(parseMethod m)
				uri
				ver
				hds
				EmptyBody -- TODO: this is wrong, and dangerous
	        _ -> Nothing
	 _ -> Nothing
       _ -> Nothing

  where parseMethod :: String -> Method
	parseMethod m
	    = case m of
		 "GET"     -> GET
		 "POST"    -> POST
		 "OPTIONS" -> OPTIONS
		 "HEAD"    -> HEAD
		 "PUT"     -> PUT
		 "DELETE"  -> DELETE
		 "TRACE"   -> TRACE
		 "CONNECT" -> CONNECT
		 str       -> ExtensionMethod str

	parseRURI :: String -> Maybe RequestURI
	parseRURI ruri =
		case ruri of
		 "*"     -> Just NoURI
		 ('/':_) -> Just $ AbsPath ruri
		 (x:_) | Just uri <- parseURI ruri
			 -> Just $ AbsURI uri
		 ""      -> Just $ AbsPath "/"
		 _	 -> Nothing

	-- Is this one really correct?
	-- It will do the right thing on a correct version spec, but
	-- isn't it possible to fool it?
	parseVersion :: String -> Maybe HTTPVersion
	parseVersion v
	    | "HTTP" `isPrefixOf` v
		= let (maj, rest) = span isDigit $ dropWhile (not . isDigit) v
		      min = takeWhile isDigit $ dropWhile (not . isDigit) rest
		  in Just $ HTTPVersion (read maj, read min)
	    | otherwise = Just $ HTTPVersion (9, 9) -- huh?
	    | otherwise = Nothing

	parseHeaders :: [String] -> Maybe [Header]
	parseHeaders [] = Just []
	parseHeaders (str:strs) =
	    case str of
		[/ fn*, ':', fv* /] -> fmap ((Header (fn, fv)):) $ parseHeaders strs
	    	_ -> Nothing