-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- 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 the copyright holder(s) nor the names of
--    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.
-- -----------------------------------------------------------------------------

module Network.MoHWS.HTTP.Request (
      T(Cons), command, uri, httpVersion, headers, body,
      toHTTPbis, fromHTTPbis,
      Command, HTTP.RequestMethod(..),
      Connection(..),
      Expect(..),
      pHeaders,
      getHost,
      getConnection,
   ) where

import Text.ParserCombinators.Parsec (Parser, skipMany1, many, noneOf, )
import Network.MoHWS.ParserUtility (pCRLF, pSP, pToken, parseList, )

import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Version as HTTPVersion
import Network.MoHWS.HTTP.Header (HasHeaders, )
import Network.MoHWS.Utility (readM, )

import qualified Network.HTTP.Base as HTTP
import qualified Network.HTTP.Headers
   -- make getHeaders visible for instance declaration

import Network.Socket (HostName, )
import Network.URI (URI, nullURI, uriPath, uriQuery, )

import qualified Data.Map as Map
import Data.Monoid (Monoid, mempty, )
import Data.Char (toLower, )


-----------------------------------------------------------------------------
-- Requests

-- Request-Line   = Method SP Request-URI SP HTTP-Version CRLF

type Command = HTTP.RequestMethod

data T body =
   Cons {
      T body -> Command
command     :: Command,
      T body -> URI
uri         :: URI,
      T body -> T
httpVersion :: HTTPVersion.T,
      T body -> Group
headers     :: Header.Group,
      T body -> body
body        :: body
   }


toHTTPbis :: T body -> HTTP.Request body
toHTTPbis :: T body -> Request body
toHTTPbis T body
req =
   Request :: forall a. URI -> Command -> [Header] -> a -> Request a
HTTP.Request {
      rqURI :: URI
HTTP.rqURI     = T body -> URI
forall body. T body -> URI
uri T body
req,
      rqMethod :: Command
HTTP.rqMethod  = T body -> Command
forall body. T body -> Command
command T body
req,
      rqHeaders :: [Header]
HTTP.rqHeaders = Group -> [Header]
Header.ungroup (Group -> [Header]) -> Group -> [Header]
forall a b. (a -> b) -> a -> b
$ T body -> Group
forall body. T body -> Group
headers T body
req,
      rqBody :: body
HTTP.rqBody    = T body -> body
forall body. T body -> body
body T body
req
   }

fromHTTPbis :: HTTP.Request body -> T body
fromHTTPbis :: Request body -> T body
fromHTTPbis Request body
req =
   Cons :: forall body. Command -> URI -> T -> Group -> body -> T body
Cons {
      command :: Command
command     = Request body -> Command
forall a. Request a -> Command
HTTP.rqMethod Request body
req,
      uri :: URI
uri         = Request body -> URI
forall a. Request a -> URI
HTTP.rqURI Request body
req,
      httpVersion :: T
httpVersion = T
HTTPVersion.http1_1,
      headers :: Group
headers     = [Header] -> Group
Header.group ([Header] -> Group) -> [Header] -> Group
forall a b. (a -> b) -> a -> b
$ Request body -> [Header]
forall a. Request a -> [Header]
HTTP.rqHeaders Request body
req,
      body :: body
body        = Request body -> body
forall a. Request a -> a
HTTP.rqBody Request body
req
   }


instance Show (T body) where
   showsPrec :: Int -> T body -> ShowS
showsPrec Int
_ Cons{command :: forall body. T body -> Command
command = Command
cmd, uri :: forall body. T body -> URI
uri = URI
loc, httpVersion :: forall body. T body -> T
httpVersion = T
ver} =
      Command -> ShowS
forall a. Show a => a -> ShowS
shows Command
cmd ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ShowS
forall a. Show a => a -> ShowS
shows URI
loc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> ShowS
forall a. Show a => a -> ShowS
shows T
ver

instance HasHeaders (T body) where
   getHeaders :: T body -> [Header]
getHeaders = Group -> [Header]
Header.ungroup (Group -> [Header]) -> (T body -> Group) -> T body -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T body -> Group
forall body. T body -> Group
headers
   setHeaders :: T body -> [Header] -> T body
setHeaders T body
req [Header]
hs = T body
req { headers :: Group
headers = [Header] -> Group
Header.group [Header]
hs}

instance Functor T where
   fmap :: (a -> b) -> T a -> T b
fmap a -> b
f T a
req =
      Cons :: forall body. Command -> URI -> T -> Group -> body -> T body
Cons {
         command :: Command
command     = T a -> Command
forall body. T body -> Command
command     T a
req,
         uri :: URI
uri         = T a -> URI
forall body. T body -> URI
uri         T a
req,
         httpVersion :: T
httpVersion = T a -> T
forall body. T body -> T
httpVersion T a
req,
         headers :: Group
headers     = T a -> Group
forall body. T body -> Group
headers     T a
req,
         body :: b
body        = a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ T a -> a
forall body. T body -> body
body T a
req
      }



-- Request parsing

-- Parse the request line and the headers, but not the body.
pHeaders :: Monoid body => Parser (T body)
pHeaders :: Parser (T body)
pHeaders =
   do (Command
cmd,URI
loc,T
ver) <- Parser (Command, URI, T)
pCommandLine
      Group
hdrs <- Parser Group
Header.pGroup
      String
_ <- Parser String
pCRLF
      T body -> Parser (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> Parser (T body)) -> T body -> Parser (T body)
forall a b. (a -> b) -> a -> b
$ Command -> URI -> T -> Group -> body -> T body
forall body. Command -> URI -> T -> Group -> body -> T body
Cons Command
cmd URI
loc T
ver Group
hdrs body
forall a. Monoid a => a
mempty

pCommandLine :: Parser (Command, URI, HTTPVersion.T)
pCommandLine :: Parser (Command, URI, T)
pCommandLine =
   do Command
cmd <- Parser Command
pCommand
      ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
pSP
      URI
loc <- Parser URI
pURI
      ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
pSP
      T
ver <- Parser T
HTTPVersion.pInRequest
      String
_ <- Parser String
pCRLF
      (Command, URI, T) -> Parser (Command, URI, T)
forall (m :: * -> *) a. Monad m => a -> m a
return (Command
cmd,URI
loc,T
ver)

commandDictionary :: Map.Map String Command
commandDictionary :: Map String Command
commandDictionary =
   [(String, Command)] -> Map String Command
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Command)] -> Map String Command)
-> [(String, Command)] -> Map String Command
forall a b. (a -> b) -> a -> b
$
   (String
"HEAD",    Command
HTTP.HEAD)    (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"PUT",     Command
HTTP.PUT)     (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"GET",     Command
HTTP.GET)     (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"POST",    Command
HTTP.POST)    (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"DELETE",  Command
HTTP.DELETE)  (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"OPTIONS", Command
HTTP.OPTIONS) (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
   (String
"TRACE",   Command
HTTP.TRACE)   (String, Command) -> [(String, Command)] -> [(String, Command)]
forall a. a -> [a] -> [a]
:
--   ("CONNECT", HTTP.CONNECT) :
   []

pCommand :: Parser Command
pCommand :: Parser Command
pCommand =
   (String -> Command) -> Parser String -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
tok -> Command -> String -> Map String Command -> Command
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> Command
HTTP.Custom String
tok) String
tok Map String Command
commandDictionary) (Parser String -> Parser Command)
-> Parser String -> Parser Command
forall a b. (a -> b) -> a -> b
$
   Parser String
pToken

pURI :: Parser URI
pURI :: Parser URI
pURI =
   do String
u <- ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
' '])
      -- FIXME: this does not handle authority Request-URIs
      -- maybe (fail "Bad Request-URI") return $ parseURIReference u
      URI -> Parser URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> Parser URI) -> URI -> Parser URI
forall a b. (a -> b) -> a -> b
$ String -> URI
laxParseURIReference String
u

-- also accepts characters [ ] " in queries, which is sometimes quite handy
laxParseURIReference :: String -> URI
laxParseURIReference :: String -> URI
laxParseURIReference String
u =
   let (String
p,String
q) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
'?'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
u
   in  URI
nullURI{uriPath :: String
uriPath=String
p, uriQuery :: String
uriQuery=String
q}

-----------------------------------------------------------------------------
-- Getting specific request headers


data Connection =
     ConnectionClose
   | ConnectionKeepAlive -- non-std?  Netscape generates it.
   | ConnectionOther String
   deriving (Connection -> Connection -> Bool
(Connection -> Connection -> Bool)
-> (Connection -> Connection -> Bool) -> Eq Connection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Connection -> Connection -> Bool
$c/= :: Connection -> Connection -> Bool
== :: Connection -> Connection -> Bool
$c== :: Connection -> Connection -> Bool
Eq, Int -> Connection -> ShowS
[Connection] -> ShowS
Connection -> String
(Int -> Connection -> ShowS)
-> (Connection -> String)
-> ([Connection] -> ShowS)
-> Show Connection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Connection] -> ShowS
$cshowList :: [Connection] -> ShowS
show :: Connection -> String
$cshow :: Connection -> String
showsPrec :: Int -> Connection -> ShowS
$cshowsPrec :: Int -> Connection -> ShowS
Show)

parseConnection :: String -> [Connection]
parseConnection :: String -> [Connection]
parseConnection =
   let fn :: String -> Connection
fn String
"close"      = Connection
ConnectionClose
       fn String
"keep-alive" = Connection
ConnectionKeepAlive
       fn String
other        = String -> Connection
ConnectionOther String
other
   in  (String -> Connection) -> [String] -> [Connection]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Connection
fn (String -> Connection) -> ShowS -> String -> Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([String] -> [Connection])
-> (String -> [String]) -> String -> [Connection]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parseList

getConnection :: HasHeaders a => a -> [Connection]
getConnection :: a -> [Connection]
getConnection =
   (String -> [Connection]) -> [String] -> [Connection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Connection]
parseConnection ([String] -> [Connection]) -> (a -> [String]) -> a -> [Connection]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> a -> [String]
forall a. HasHeaders a => Name -> a -> [String]
Header.lookupMany Name
Header.HdrConnection

data Expect = ExpectContinue
  deriving Int -> Expect -> ShowS
[Expect] -> ShowS
Expect -> String
(Int -> Expect -> ShowS)
-> (Expect -> String) -> ([Expect] -> ShowS) -> Show Expect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expect] -> ShowS
$cshowList :: [Expect] -> ShowS
show :: Expect -> String
$cshow :: Expect -> String
showsPrec :: Int -> Expect -> ShowS
$cshowsPrec :: Int -> Expect -> ShowS
Show

-- parseExpect :: String -> Maybe Expect
-- parseExpect s =
--   case parseList s of
--      ["100-continue"] -> Just ExpectContinue
--      _                -> Nothing


getHost :: HasHeaders a => a -> Maybe (HostName, Maybe Int)
getHost :: a -> Maybe (String, Maybe Int)
getHost a
x = Name -> a -> Maybe String
forall a. HasHeaders a => Name -> a -> Maybe String
Header.lookup Name
Header.HdrHost a
x Maybe String
-> (String -> Maybe (String, Maybe Int))
-> Maybe (String, Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe (String, Maybe Int)
parseHost

parseHost :: String -> Maybe (HostName, Maybe Int)
parseHost :: String -> Maybe (String, Maybe Int)
parseHost String
s =
   let (String
host,String
prt) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
s
   in  case String
prt of
          String
""       -> (String, Maybe Int) -> Maybe (String, Maybe Int)
forall a. a -> Maybe a
Just (String
host, Maybe Int
forall a. Maybe a
Nothing)
          Char
':':String
port -> String -> Maybe Int
forall a (m :: * -> *). (Read a, MonadFail m) => String -> m a
readM String
port Maybe Int
-> (Int -> Maybe (String, Maybe Int)) -> Maybe (String, Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
p -> (String, Maybe Int) -> Maybe (String, Maybe Int)
forall a. a -> Maybe a
Just (String
host, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
p)
          String
_        -> Maybe (String, Maybe Int)
forall a. Maybe a
Nothing