{-# LANGUAGE CPP, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.Base
-- Copyright   :  See LICENSE file
-- License     :  BSD
-- 
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- Definitions of @Request@ and @Response@ types along with functions
-- for normalizing them. It is assumed to be an internal module; user
-- code should, if possible, import @Network.HTTP@ to access the functionality
-- that this module provides.
--
-- Additionally, the module exports internal functions for working with URLs,
-- and for handling the processing of requests and responses coming back.
--
-----------------------------------------------------------------------------
module Network.HTTP.Base
       (
          -- ** Constants
         httpVersion                 -- :: String

          -- ** HTTP
       , Request(..)
       , Response(..)
       , RequestMethod(..)
       
       , Request_String
       , Response_String
       , HTTPRequest
       , HTTPResponse
       
          -- ** URL Encoding
       , urlEncode
       , urlDecode
       , urlEncodeVars

          -- ** URI authority parsing
       , URIAuthority(..)
       , parseURIAuthority
       
          -- internal
       , uriToAuthorityString   -- :: URI     -> String
       , uriAuthToString        -- :: URIAuth -> String
       , uriAuthPort            -- :: Maybe URI -> URIAuth -> Int
       , reqURIAuth             -- :: Request ty -> URIAuth

       , parseResponseHead      -- :: [String] -> Result ResponseData
       , parseRequestHead       -- :: [String] -> Result RequestData

       , ResponseNextStep(..)
       , matchResponse
       , ResponseData
       , ResponseCode
       , RequestData
       
       , NormalizeRequestOptions(..) 
       , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty
       , RequestNormalizer

       , normalizeRequest   -- :: NormalizeRequestOptions ty -> Request ty -> Request ty

       , splitRequestURI

       , getAuth
       , normalizeRequestURI
       , normalizeHostHeader
       , findConnClose

         -- internal export (for the use by Network.HTTP.{Stream,ByteStream} )
       , linearTransfer
       , hopefulTransfer
       , chunkedTransfer
       , uglyDeathTransfer
       , readTillEmpty1
       , readTillEmpty2
       
       , defaultGETRequest
       , defaultGETRequest_
       , mkRequest
       , setRequestBody

       , defaultUserAgent
       , httpPackageVersion
       , libUA  {- backwards compatibility, will disappear..soon -}
       
       , catchIO
       , catchIO_
       , responseParseError
       
       , getRequestVersion
       , getResponseVersion
       , setRequestVersion
       , setResponseVersion

       , failHTTPS
       
       ) where

import Network.URI
   ( URI(uriAuthority, uriPath, uriScheme)
   , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)
   , parseURIReference
   )

import Control.Monad ( guard )
import Control.Monad.Error.Class ()
import Data.Bits     ( (.&.), (.|.), shiftL, shiftR )
import Data.Word     ( Word8 )
import Data.Char     ( digitToInt, intToDigit, toLower, isDigit,
                       isAscii, isAlphaNum, ord, chr )
import Data.List     ( partition, find )
import Data.Maybe    ( listToMaybe, fromMaybe )
import Numeric       ( readHex )

import Network.Stream
import Network.BufferType ( BufferOp(..), BufferType(..) )
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, crlf, sp, readsOne )
import qualified Network.HTTP.Base64 as Base64 (encode)

import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
   ( ReadP, readP_to_S, char, (<++), look, munch, munch1 )

import Control.Exception as Exception (catch, IOException)

import qualified Paths_HTTP as Self (version)
import Data.Version (showVersion)

-----------------------------------------------------------------
------------------ URI Authority parsing ------------------------
-----------------------------------------------------------------

data URIAuthority = URIAuthority { URIAuthority -> Maybe [Char]
user :: Maybe String,
                                   URIAuthority -> Maybe [Char]
password :: Maybe String,
                                   URIAuthority -> [Char]
host :: String,
                                   URIAuthority -> Maybe Int
port :: Maybe Int
                                 } deriving (URIAuthority -> URIAuthority -> Bool
(URIAuthority -> URIAuthority -> Bool)
-> (URIAuthority -> URIAuthority -> Bool) -> Eq URIAuthority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIAuthority -> URIAuthority -> Bool
$c/= :: URIAuthority -> URIAuthority -> Bool
== :: URIAuthority -> URIAuthority -> Bool
$c== :: URIAuthority -> URIAuthority -> Bool
Eq,Int -> URIAuthority -> ShowS
[URIAuthority] -> ShowS
URIAuthority -> [Char]
(Int -> URIAuthority -> ShowS)
-> (URIAuthority -> [Char])
-> ([URIAuthority] -> ShowS)
-> Show URIAuthority
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [URIAuthority] -> ShowS
$cshowList :: [URIAuthority] -> ShowS
show :: URIAuthority -> [Char]
$cshow :: URIAuthority -> [Char]
showsPrec :: Int -> URIAuthority -> ShowS
$cshowsPrec :: Int -> URIAuthority -> ShowS
Show)

-- | Parse the authority part of a URL.
--
-- > RFC 1732, section 3.1:
-- >
-- >       //<user>:<password>@<host>:<port>/<url-path>
-- >  Some or all of the parts "<user>:<password>@", ":<password>",
-- >  ":<port>", and "/<url-path>" may be excluded.
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority :: [Char] -> Maybe URIAuthority
parseURIAuthority [Char]
s = [URIAuthority] -> Maybe URIAuthority
forall a. [a] -> Maybe a
listToMaybe (((URIAuthority, [Char]) -> URIAuthority)
-> [(URIAuthority, [Char])] -> [URIAuthority]
forall a b. (a -> b) -> [a] -> [b]
map (URIAuthority, [Char]) -> URIAuthority
forall a b. (a, b) -> a
fst (ReadP URIAuthority -> ReadS URIAuthority
forall a. ReadP a -> ReadS a
readP_to_S ReadP URIAuthority
pURIAuthority [Char]
s))


pURIAuthority :: ReadP URIAuthority
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
                (Maybe [Char]
u,Maybe [Char]
pw) <- (ReadP (Maybe [Char], Maybe [Char])
pUserInfo ReadP (Maybe [Char], Maybe [Char])
-> ReadP Char -> ReadP (Maybe [Char], Maybe [Char])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
`before` Char -> ReadP Char
char Char
'@')
                          ReadP (Maybe [Char], Maybe [Char])
-> ReadP (Maybe [Char], Maybe [Char])
-> ReadP (Maybe [Char], Maybe [Char])
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Maybe [Char], Maybe [Char]) -> ReadP (Maybe [Char], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [Char]
forall a. Maybe a
Nothing)
                [Char]
h <- ReadP [Char]
rfc2732host ReadP [Char] -> ReadP [Char] -> ReadP [Char]
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Char -> Bool) -> ReadP [Char]
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':')
                Maybe Int
p <- ReadP Int -> ReadP (Maybe Int)
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char Char
':' ReadP Char -> ReadP Int -> ReadP Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Int
forall a. (Eq a, Num a) => ReadP a
readDecP)
                ReadP [Char]
look ReadP [Char] -> ([Char] -> ReadP ()) -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReadP ()) -> ([Char] -> Bool) -> [Char] -> ReadP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
                URIAuthority -> ReadP URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority :: Maybe [Char] -> Maybe [Char] -> [Char] -> Maybe Int -> URIAuthority
URIAuthority{ user :: Maybe [Char]
user=Maybe [Char]
u, password :: Maybe [Char]
password=Maybe [Char]
pw, host :: [Char]
host=[Char]
h, port :: Maybe Int
port=Maybe Int
p }

-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL
rfc2732host :: ReadP String
rfc2732host :: ReadP [Char]
rfc2732host = do
    Char
_ <- Char -> ReadP Char
char Char
'['
    [Char]
res <- (Char -> Bool) -> ReadP [Char]
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
']')
    Char
_ <- Char -> ReadP Char
char Char
']'
    [Char] -> ReadP [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
res

pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo :: ReadP (Maybe [Char], Maybe [Char])
pUserInfo = do
            Maybe [Char]
u <- ReadP [Char] -> ReadP (Maybe [Char])
forall a. ReadP a -> ReadP (Maybe a)
orNothing ((Char -> Bool) -> ReadP [Char]
munch (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char]
":@"))
            Maybe [Char]
p <- ReadP [Char] -> ReadP (Maybe [Char])
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char Char
':' ReadP Char -> ReadP [Char] -> ReadP [Char]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP [Char]
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@'))
            (Maybe [Char], Maybe [Char]) -> ReadP (Maybe [Char], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
u,Maybe [Char]
p)

before :: Monad m => m a -> m b -> m a
before :: forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
before m a
a m b
b = m a
a m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> m b
b m b -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

orNothing :: ReadP a -> ReadP (Maybe a)
orNothing :: forall a. ReadP a -> ReadP (Maybe a)
orNothing ReadP a
p = (a -> Maybe a) -> ReadP a -> ReadP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just ReadP a
p ReadP (Maybe a) -> ReadP (Maybe a) -> ReadP (Maybe a)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Maybe a -> ReadP (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- This function duplicates old Network.URI.authority behaviour.
uriToAuthorityString :: URI -> String
uriToAuthorityString :: URI -> [Char]
uriToAuthorityString URI
u = [Char] -> (URIAuth -> [Char]) -> Maybe URIAuth -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" URIAuth -> [Char]
uriAuthToString (URI -> Maybe URIAuth
uriAuthority URI
u)

uriAuthToString :: URIAuth -> String
uriAuthToString :: URIAuth -> [Char]
uriAuthToString URIAuth
ua = 
  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ URIAuth -> [Char]
uriUserInfo URIAuth
ua 
         , URIAuth -> [Char]
uriRegName URIAuth
ua
         , URIAuth -> [Char]
uriPort URIAuth
ua
         ]

uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort Maybe URI
mbURI URIAuth
u = 
  case URIAuth -> [Char]
uriPort URIAuth
u of
    (Char
':':[Char]
s) -> (Int -> Int) -> Int -> [Char] -> Int
forall a b. Read a => (a -> b) -> b -> [Char] -> b
readsOne Int -> Int
forall a. a -> a
id (Maybe URI -> Int
default_port Maybe URI
mbURI) [Char]
s
    [Char]
_       -> Maybe URI -> Int
default_port Maybe URI
mbURI
 where
  default_port :: Maybe URI -> Int
default_port Maybe URI
Nothing = Int
default_http
  default_port (Just URI
url) = 
    case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ URI -> [Char]
uriScheme URI
url of
      [Char]
"http:" -> Int
default_http
      [Char]
"https:" -> Int
default_https
        -- todo: refine
      [Char]
_ -> Int
default_http

  default_http :: Int
default_http  = Int
80
  default_https :: Int
default_https = Int
443

#if MIN_VERSION_base(4,13,0)
failHTTPS :: MonadFail m => URI -> m ()
#else
failHTTPS :: Monad m => URI -> m ()
#endif
failHTTPS :: forall (m :: * -> *). MonadFail m => URI -> m ()
failHTTPS URI
uri
  | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (URI -> [Char]
uriScheme URI
uri) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"https:" = [Char] -> m ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"https not supported"
  | Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Fish out the authority from a possibly normalized Request, i.e.,
-- the information may either be in the request's URI or inside
-- the Host: header.
reqURIAuth :: Request ty -> URIAuth
reqURIAuth :: forall ty. Request ty -> URIAuth
reqURIAuth Request ty
req = 
  case URI -> Maybe URIAuth
uriAuthority (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req) of
    Just URIAuth
ua -> URIAuth
ua
    Maybe URIAuth
_ -> case HeaderName -> [Header] -> Maybe [Char]
lookupHeader HeaderName
HdrHost (Request ty -> [Header]
forall a. Request a -> [Header]
rqHeaders Request ty
req) of
           Maybe [Char]
Nothing -> [Char] -> URIAuth
forall a. HasCallStack => [Char] -> a
error ([Char]
"reqURIAuth: no URI authority for: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Request ty -> [Char]
forall a. Show a => a -> [Char]
show Request ty
req)
           Just [Char]
h  ->
              case [Char] -> ([Char], [Char])
toHostPort [Char]
h of
                ([Char]
ht,[Char]
p) -> URIAuth :: [Char] -> [Char] -> [Char] -> URIAuth
URIAuth { uriUserInfo :: [Char]
uriUserInfo = [Char]
""
                                  , uriRegName :: [Char]
uriRegName  = [Char]
ht
                                  , uriPort :: [Char]
uriPort     = [Char]
p
                                  }
  where
    -- Note: just in case you're wondering..the convention is to include the ':'
    -- in the port part..
   toHostPort :: [Char] -> ([Char], [Char])
toHostPort [Char]
h = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') [Char]
h

-----------------------------------------------------------------
------------------ HTTP Messages --------------------------------
-----------------------------------------------------------------


-- Protocol version
httpVersion :: String
httpVersion :: [Char]
httpVersion = [Char]
"HTTP/1.1"


-- | The HTTP request method, to be used in the 'Request' object.
-- We are missing a few of the stranger methods, but these are
-- not really necessary until we add full TLS.
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String
    deriving(RequestMethod -> RequestMethod -> Bool
(RequestMethod -> RequestMethod -> Bool)
-> (RequestMethod -> RequestMethod -> Bool) -> Eq RequestMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestMethod -> RequestMethod -> Bool
$c/= :: RequestMethod -> RequestMethod -> Bool
== :: RequestMethod -> RequestMethod -> Bool
$c== :: RequestMethod -> RequestMethod -> Bool
Eq)

instance Show RequestMethod where
  show :: RequestMethod -> [Char]
show RequestMethod
x = 
    case RequestMethod
x of
      RequestMethod
HEAD     -> [Char]
"HEAD"
      RequestMethod
PUT      -> [Char]
"PUT"
      RequestMethod
GET      -> [Char]
"GET"
      RequestMethod
POST     -> [Char]
"POST"
      RequestMethod
DELETE   -> [Char]
"DELETE"
      RequestMethod
OPTIONS  -> [Char]
"OPTIONS"
      RequestMethod
TRACE    -> [Char]
"TRACE"
      RequestMethod
CONNECT  -> [Char]
"CONNECT"
      Custom [Char]
c -> [Char]
c

rqMethodMap :: [(String, RequestMethod)]
rqMethodMap :: [([Char], RequestMethod)]
rqMethodMap = [([Char]
"HEAD",    RequestMethod
HEAD),
               ([Char]
"PUT",     RequestMethod
PUT),
               ([Char]
"GET",     RequestMethod
GET),
               ([Char]
"POST",    RequestMethod
POST),
               ([Char]
"DELETE",  RequestMethod
DELETE),
               ([Char]
"OPTIONS", RequestMethod
OPTIONS),
               ([Char]
"TRACE",   RequestMethod
TRACE),
               ([Char]
"CONNECT", RequestMethod
CONNECT)]

-- 
-- for backwards-ish compatibility; suggest
-- migrating to new Req/Resp by adding type param.
-- 
type Request_String  = Request String
type Response_String = Response String

-- Hmm..I really want to use these for the record
-- type, but it will upset codebases wanting to
-- migrate (and live with using pre-HTTPbis versions.)
type HTTPRequest a  = Request  a
type HTTPResponse a = Response a

-- | An HTTP Request.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output.
data Request a =
     Request { forall a. Request a -> URI
rqURI       :: URI   -- ^ might need changing in future
                                    --  1) to support '*' uri in OPTIONS request
                                    --  2) transparent support for both relative
                                    --     & absolute uris, although this should
                                    --     already work (leave scheme & host parts empty).
             , forall a. Request a -> RequestMethod
rqMethod    :: RequestMethod
             , forall a. Request a -> [Header]
rqHeaders   :: [Header]
             , forall a. Request a -> a
rqBody      :: a
             }

-- Notice that request body is not included,
-- this show function is used to serialise
-- a request for the transport link, we send
-- the body separately where possible.
instance Show (Request a) where
    show :: Request a -> [Char]
show req :: Request a
req@(Request URI
u RequestMethod
m [Header]
h a
_) =
        RequestMethod -> [Char]
forall a. Show a => a -> [Char]
show RequestMethod
m [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
alt_uri [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ver [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
crlf
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char] -> ShowS) -> [Char] -> [[Char]] -> [Char]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> [Char]) -> [Header] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Header -> [Char]
forall a. Show a => a -> [Char]
show ([Header] -> [Header]
dropHttpVersion [Header]
h)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
crlf
        where
            ver :: [Char]
ver = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
httpVersion (Request a -> Maybe [Char]
forall a. Request a -> Maybe [Char]
getRequestVersion Request a
req)
            alt_uri :: [Char]
alt_uri = URI -> [Char]
forall a. Show a => a -> [Char]
show (URI -> [Char]) -> URI -> [Char]
forall a b. (a -> b) -> a -> b
$ if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriPath URI
u) Bool -> Bool -> Bool
|| [Char] -> Char
forall a. [a] -> a
head (URI -> [Char]
uriPath URI
u) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' 
                        then URI
u { uriPath :: [Char]
uriPath = Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: URI -> [Char]
uriPath URI
u } 
                        else URI
u

instance HasHeaders (Request a) where
    getHeaders :: Request a -> [Header]
getHeaders = Request a -> [Header]
forall a. Request a -> [Header]
rqHeaders
    setHeaders :: Request a -> [Header] -> Request a
setHeaders Request a
rq [Header]
hdrs = Request a
rq { rqHeaders :: [Header]
rqHeaders=[Header]
hdrs }

-- | For easy pattern matching, HTTP response codes @xyz@ are
-- represented as @(x,y,z)@.
type ResponseCode  = (Int,Int,Int)

-- | @ResponseData@ contains the head of a response payload;
-- HTTP response code, accompanying text description + header
-- fields.
type ResponseData  = (ResponseCode,String,[Header])

-- | @RequestData@ contains the head of a HTTP request; method,
-- its URL along with the auxillary/supporting header data.
type RequestData   = (RequestMethod,URI,[Header])

-- | An HTTP Response.
-- The 'Show' instance of this type is used for message serialisation,
-- which means no body data is output, additionally the output will
-- show an HTTP version of 1.1 instead of the actual version returned
-- by a server.
data Response a =
    Response { forall a. Response a -> ResponseCode
rspCode     :: ResponseCode
             , forall a. Response a -> [Char]
rspReason   :: String
             , forall a. Response a -> [Header]
rspHeaders  :: [Header]
             , forall a. Response a -> a
rspBody     :: a
             }
                   
-- This is an invalid representation of a received response, 
-- since we have made the assumption that all responses are HTTP/1.1
instance Show (Response a) where
    show :: Response a -> [Char]
show rsp :: Response a
rsp@(Response (Int
a,Int
b,Int
c) [Char]
reason [Header]
headers a
_) =
        [Char]
ver [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
reason [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
crlf
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char] -> ShowS) -> [Char] -> [[Char]] -> [Char]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> [Char]) -> [Header] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Header -> [Char]
forall a. Show a => a -> [Char]
show ([Header] -> [Header]
dropHttpVersion [Header]
headers)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
crlf
     where
      ver :: [Char]
ver = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
httpVersion (Response a -> Maybe [Char]
forall a. Response a -> Maybe [Char]
getResponseVersion Response a
rsp)

instance HasHeaders (Response a) where
    getHeaders :: Response a -> [Header]
getHeaders = Response a -> [Header]
forall a. Response a -> [Header]
rspHeaders
    setHeaders :: Response a -> [Header] -> Response a
setHeaders Response a
rsp [Header]
hdrs = Response a
rsp { rspHeaders :: [Header]
rspHeaders=[Header]
hdrs }


------------------------------------------------------------------
------------------ Request Building ------------------------------
------------------------------------------------------------------

-- | Deprecated. Use 'defaultUserAgent'
libUA :: String
libUA :: [Char]
libUA = [Char]
"hs-HTTP-4000.0.9"
{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-}

-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@
-- where @$version@ is the version of this HTTP package.
--
defaultUserAgent :: String
defaultUserAgent :: [Char]
defaultUserAgent = [Char]
"haskell-HTTP/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
httpPackageVersion

-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This
-- may be useful to include in a user agent string so that you can determine
-- from server logs what version of this package HTTP clients are using.
-- This can be useful for tracking down HTTP compatibility quirks.
--
httpPackageVersion :: String
httpPackageVersion :: [Char]
httpPackageVersion = Version -> [Char]
showVersion Version
Self.version

defaultGETRequest :: URI -> Request_String
defaultGETRequest :: URI -> Request_String
defaultGETRequest URI
uri = URI -> Request_String
forall a. BufferType a => URI -> Request a
defaultGETRequest_ URI
uri

defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ :: forall a. BufferType a => URI -> Request a
defaultGETRequest_ URI
uri = RequestMethod -> URI -> Request a
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
mkRequest RequestMethod
GET URI
uri 

-- | 'mkRequest method uri' constructs a well formed
-- request for the given HTTP method and URI. It does not
-- normalize the URI for the request _nor_ add the required 
-- Host: header. That is done either explicitly by the user
-- or when requests are normalized prior to transmission.
mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty
mkRequest :: forall ty. BufferType ty => RequestMethod -> URI -> Request ty
mkRequest RequestMethod
meth URI
uri = Request ty
req
 where
  req :: Request ty
req = 
    Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqURI :: URI
rqURI      = URI
uri
            , rqBody :: ty
rqBody     = ty
empty
            , rqHeaders :: [Header]
rqHeaders  = [ HeaderName -> [Char] -> Header
Header HeaderName
HdrContentLength [Char]
"0"
                           , HeaderName -> [Char] -> Header
Header HeaderName
HdrUserAgent     [Char]
defaultUserAgent
                           ]
            , rqMethod :: RequestMethod
rqMethod   = RequestMethod
meth
            }

  empty :: ty
empty = BufferOp ty -> ty
forall a. BufferOp a -> a
buf_empty (Request ty -> BufferOp ty
forall a. BufferType a => Request a -> BufferOp a
toBufOps Request ty
req)

-- set rqBody, Content-Type and Content-Length headers.
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody :: Request_String -> ([Char], [Char]) -> Request_String
setRequestBody Request_String
req ([Char]
typ, [Char]
body) = Request_String
req' { rqBody :: [Char]
rqBody=[Char]
body }
  where
    req' :: Request_String
req' = HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentType [Char]
typ (Request_String -> Request_String)
-> (Request_String -> Request_String)
-> Request_String
-> Request_String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentLength (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
body) (Request_String -> Request_String)
-> Request_String -> Request_String
forall a b. (a -> b) -> a -> b
$
           Request_String
req

{-
    -- stub out the user info.
  updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)

  withHost = 
    case uriToAuthorityString uri{uriAuthority=updAuth} of
      "" -> id
      h  -> ((Header HdrHost h):)

  uri_req 
   | forProxy  = uri
   | otherwise = snd (splitRequestURI uri)
-}


toBufOps :: BufferType a => Request a -> BufferOp a
toBufOps :: forall a. BufferType a => Request a -> BufferOp a
toBufOps Request a
_ = BufferOp a
forall bufType. BufferType bufType => BufferOp bufType
bufferOps

-----------------------------------------------------------------
------------------ Parsing --------------------------------------
-----------------------------------------------------------------

-- Parsing a request
parseRequestHead :: [String] -> Result RequestData
parseRequestHead :: [[Char]] -> Result RequestData
parseRequestHead         [] = ConnError -> Result RequestData
forall a b. a -> Either a b
Left ConnError
ErrorClosed
parseRequestHead ([Char]
com:[[Char]]
hdrs) = do
  ([[Char]]
version,RequestMethod
rqm,URI
uri) <- [Char]
-> [[Char]] -> Either ConnError ([[Char]], RequestMethod, URI)
requestCommand [Char]
com ([Char] -> [[Char]]
words [Char]
com)
  [Header]
hdrs'              <- [[Char]] -> Result [Header]
parseHeaders [[Char]]
hdrs
  RequestData -> Result RequestData
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMethod
rqm,URI
uri,[[Char]] -> [Header] -> [Header]
withVer [[Char]]
version [Header]
hdrs')
 where
  withVer :: [[Char]] -> [Header] -> [Header]
withVer [] [Header]
hs = [Header]
hs
  withVer ([Char]
h:[[Char]]
_) [Header]
hs = [Char] -> [Header] -> [Header]
withVersion [Char]
h [Header]
hs

  requestCommand :: [Char]
-> [[Char]] -> Either ConnError ([[Char]], RequestMethod, URI)
requestCommand [Char]
l _yes :: [[Char]]
_yes@([Char]
rqm:[Char]
uri:[[Char]]
version) =
    case ([Char] -> Maybe URI
parseURIReference [Char]
uri, [Char] -> [([Char], RequestMethod)] -> Maybe RequestMethod
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
rqm [([Char], RequestMethod)]
rqMethodMap) of
     (Just URI
u, Just RequestMethod
r) -> ([[Char]], RequestMethod, URI)
-> Either ConnError ([[Char]], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]]
version,RequestMethod
r,URI
u)
     (Just URI
u, Maybe RequestMethod
Nothing) -> ([[Char]], RequestMethod, URI)
-> Either ConnError ([[Char]], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]]
version,[Char] -> RequestMethod
Custom [Char]
rqm,URI
u)
     (Maybe URI, Maybe RequestMethod)
_                -> [Char] -> Either ConnError ([[Char]], RequestMethod, URI)
forall {a}. [Char] -> Result a
parse_err [Char]
l
  requestCommand [Char]
l [[Char]]
_
   | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
l    = ConnError -> Either ConnError ([[Char]], RequestMethod, URI)
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
   | Bool
otherwise = [Char] -> Either ConnError ([[Char]], RequestMethod, URI)
forall {a}. [Char] -> Result a
parse_err [Char]
l

  parse_err :: [Char] -> Result a
parse_err [Char]
l = [Char] -> [Char] -> Result a
forall a. [Char] -> [Char] -> Result a
responseParseError [Char]
"parseRequestHead"
                   ([Char]
"Request command line parse failure: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
l)

-- Parsing a response
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead :: [[Char]] -> Result ResponseData
parseResponseHead []         = ConnError -> Result ResponseData
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
parseResponseHead ([Char]
sts:[[Char]]
hdrs) = do
  ([Char]
version,ResponseCode
code,[Char]
reason)  <- [Char]
-> [[Char]] -> Either ConnError ([Char], ResponseCode, [Char])
responseStatus [Char]
sts ([Char] -> [[Char]]
words [Char]
sts)
  [Header]
hdrs'                  <- [[Char]] -> Result [Header]
parseHeaders [[Char]]
hdrs
  ResponseData -> Result ResponseData
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseCode
code,[Char]
reason, [Char] -> [Header] -> [Header]
withVersion [Char]
version [Header]
hdrs')
 where
  responseStatus :: [Char]
-> [[Char]] -> Either ConnError ([Char], ResponseCode, [Char])
responseStatus [Char]
_l _yes :: [[Char]]
_yes@([Char]
version:[Char]
code:[[Char]]
reason) =
    ([Char], ResponseCode, [Char])
-> Either ConnError ([Char], ResponseCode, [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
version,[Char] -> ResponseCode
match [Char]
code,ShowS -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
" ") [[Char]]
reason)
  responseStatus [Char]
l [[Char]]
_no 
    | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
l    = ConnError -> Either ConnError ([Char], ResponseCode, [Char])
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed  -- an assumption
    | Bool
otherwise = [Char] -> Either ConnError ([Char], ResponseCode, [Char])
forall {a}. [Char] -> Result a
parse_err [Char]
l

  parse_err :: [Char] -> Result a
parse_err [Char]
l = 
    [Char] -> [Char] -> Result a
forall a. [Char] -> [Char] -> Result a
responseParseError 
        [Char]
"parseResponseHead"
        ([Char]
"Response status line parse failure: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
l)

  match :: [Char] -> ResponseCode
match [Char
a,Char
b,Char
c] = (Char -> Int
digitToInt Char
a,
                   Char -> Int
digitToInt Char
b,
                   Char -> Int
digitToInt Char
c)
  match [Char]
_ = (-Int
1,-Int
1,-Int
1)  -- will create appropriate behaviour

-- To avoid changing the @RequestData@ and @ResponseData@ types
-- just for this (and the upstream backwards compat. woes that
-- will result in), encode version info as a custom header.
-- Used by 'parseResponseData' and 'parseRequestData'.
--
-- Note: the Request and Response types do not currently represent
-- the version info explicitly in their record types. You have to use
-- {get,set}{Request,Response}Version for that.
withVersion :: String -> [Header] -> [Header]
withVersion :: [Char] -> [Header] -> [Header]
withVersion [Char]
v [Header]
hs 
 | [Char]
v [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
httpVersion = [Header]
hs  -- don't bother adding it if the default.
 | Bool
otherwise        = (HeaderName -> [Char] -> Header
Header ([Char] -> HeaderName
HdrCustom [Char]
"X-HTTP-Version") [Char]
v) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
hs

-- | @getRequestVersion req@ returns the HTTP protocol version of
-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.
getRequestVersion :: Request a -> Maybe String
getRequestVersion :: forall a. Request a -> Maybe [Char]
getRequestVersion Request a
r = Request a -> Maybe [Char]
forall a. HasHeaders a => a -> Maybe [Char]
getHttpVersion Request a
r

-- | @setRequestVersion v req@ returns a new request, identical to
-- @req@, but with its HTTP version set to @v@.
setRequestVersion :: String -> Request a -> Request a
setRequestVersion :: forall a. [Char] -> Request a -> Request a
setRequestVersion [Char]
s Request a
r = Request a -> [Char] -> Request a
forall a. HasHeaders a => a -> [Char] -> a
setHttpVersion Request a
r [Char]
s


-- | @getResponseVersion rsp@ returns the HTTP protocol version of
-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be 
-- assumed.
getResponseVersion :: Response a -> Maybe String
getResponseVersion :: forall a. Response a -> Maybe [Char]
getResponseVersion Response a
r = Response a -> Maybe [Char]
forall a. HasHeaders a => a -> Maybe [Char]
getHttpVersion Response a
r

-- | @setResponseVersion v rsp@ returns a new response, identical to
-- @rsp@, but with its HTTP version set to @v@.
setResponseVersion :: String -> Response a -> Response a
setResponseVersion :: forall a. [Char] -> Response a -> Response a
setResponseVersion [Char]
s Response a
r = Response a -> [Char] -> Response a
forall a. HasHeaders a => a -> [Char] -> a
setHttpVersion Response a
r [Char]
s

-- internal functions for accessing HTTP-version info in
-- requests and responses. Not exported as it exposes ho
-- version info is represented internally.

getHttpVersion :: HasHeaders a => a -> Maybe String
getHttpVersion :: forall a. HasHeaders a => a -> Maybe [Char]
getHttpVersion a
r = 
  (Header -> [Char]) -> Maybe Header -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Header -> [Char]
toVersion      (Maybe Header -> Maybe [Char]) -> Maybe Header -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
   (Header -> Bool) -> [Header] -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Header -> Bool
isHttpVersion ([Header] -> Maybe Header) -> [Header] -> Maybe Header
forall a b. (a -> b) -> a -> b
$
    a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r
 where
  toVersion :: Header -> [Char]
toVersion (Header HeaderName
_ [Char]
x) = [Char]
x

setHttpVersion :: HasHeaders a => a -> String -> a
setHttpVersion :: forall a. HasHeaders a => a -> [Char] -> a
setHttpVersion a
r [Char]
v = 
  a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
r ([Header] -> a) -> [Header] -> a
forall a b. (a -> b) -> a -> b
$
   [Char] -> [Header] -> [Header]
withVersion [Char]
v  ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
    [Header] -> [Header]
dropHttpVersion ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
     a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r

dropHttpVersion :: [Header] -> [Header]
dropHttpVersion :: [Header] -> [Header]
dropHttpVersion [Header]
hs = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Header -> Bool
isHttpVersion) [Header]
hs

isHttpVersion :: Header -> Bool
isHttpVersion :: Header -> Bool
isHttpVersion (Header (HdrCustom [Char]
"X-HTTP-Version") [Char]
_) = Bool
True
isHttpVersion Header
_ = Bool
False    



-----------------------------------------------------------------
------------------ HTTP Send / Recv ----------------------------------
-----------------------------------------------------------------

data ResponseNextStep
 = Continue
 | Retry
 | Done
 | ExpectEntity
 | DieHorribly String

matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse RequestMethod
rqst ResponseCode
rsp =
    case ResponseCode
rsp of
        (Int
1,Int
0,Int
0) -> ResponseNextStep
Continue
        (Int
1,Int
0,Int
1) -> ResponseNextStep
Done        -- upgrade to TLS
        (Int
1,Int
_,Int
_) -> ResponseNextStep
Continue    -- default
        (Int
2,Int
0,Int
4) -> ResponseNextStep
Done
        (Int
2,Int
0,Int
5) -> ResponseNextStep
Done
        (Int
2,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
3,Int
0,Int
4) -> ResponseNextStep
Done
        (Int
3,Int
0,Int
5) -> ResponseNextStep
Done
        (Int
3,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
4,Int
1,Int
7) -> ResponseNextStep
Retry       -- Expectation failed
        (Int
4,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
5,Int
_,Int
_) -> ResponseNextStep
ans
        (Int
a,Int
b,Int
c) -> [Char] -> ResponseNextStep
DieHorribly ([Char]
"Response code " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" not recognised")
    where
        ans :: ResponseNextStep
ans | RequestMethod
rqst RequestMethod -> RequestMethod -> Bool
forall a. Eq a => a -> a -> Bool
== RequestMethod
HEAD = ResponseNextStep
Done
            | Bool
otherwise    = ResponseNextStep
ExpectEntity
        

        
-----------------------------------------------------------------
------------------ A little friendly funtionality ---------------
-----------------------------------------------------------------


{-
    I had a quick look around but couldn't find any RFC about
    the encoding of data on the query string.  I did find an
    IETF memo, however, so this is how I justify the urlEncode
    and urlDecode methods.

    Doc name: draft-tiwari-appl-wxxx-forms-01.txt  (look on www.ietf.org)

    Reserved chars:  ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.
    Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
    URI delims: "<" | ">" | "#" | "%" | <">
    Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>
                     <US-ASCII coded character 20 hexadecimal>
    Also unallowed:  any non-us-ascii character

    Escape method: char -> '%' a b  where a, b :: Hex digits
-}

replacement_character :: Char
replacement_character :: Char
replacement_character = Char
'\xfffd'

-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format.
--
-- Shamelessly stolen from utf-8string-0.3.7
encodeChar :: Char -> [Word8]
encodeChar :: Char -> [Word8]
encodeChar = (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Word8]) -> (Char -> [Int]) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall {a}. (Ord a, Num a, Bits a) => a -> [a]
go (Int -> [Int]) -> (Char -> Int) -> Char -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
 where
  go :: a -> [a]
go a
oc
   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7f       = [a
oc]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7ff      = [ a
0xc0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xffff     = [ a
0xe0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]
   | Bool
otherwise        = [ a
0xf0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
18)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]

-- | Decode a UTF8 string packed into a list of Word8 values, directly to String
--
-- Shamelessly stolen from utf-8string-0.3.7
decode :: [Word8] -> String
decode :: [Word8] -> [Char]
decode [    ] = [Char]
""
decode (Word8
c:[Word8]
cs)
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80  = Int -> Char
chr (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c) Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
cs
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xc0  = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
cs
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xe0  = [Char]
multi1
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf0  = Int -> Word8 -> Int -> [Char]
multi_byte Int
2 Word8
0xf  Int
0x800
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf8  = Int -> Word8 -> Int -> [Char]
multi_byte Int
3 Word8
0x7  Int
0x10000
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xfc  = Int -> Word8 -> Int -> [Char]
multi_byte Int
4 Word8
0x3  Int
0x200000
  | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xfe  = Int -> Word8 -> Int -> [Char]
multi_byte Int
5 Word8
0x1  Int
0x4000000
  | Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
cs
  where
    multi1 :: [Char]
multi1 = case [Word8]
cs of
      Word8
c1 : [Word8]
ds | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 ->
        let d :: Int
d = ((Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x1f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.  Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)
        in if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x000080 then Int -> Char
forall a. Enum a => Int -> a
toEnum Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
ds
                            else Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
ds
      [Word8]
_ -> Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
cs

    multi_byte :: Int -> Word8 -> Int -> [Char]
    multi_byte :: Int -> Word8 -> Int -> [Char]
multi_byte Int
i Word8
mask Int
overlong = Int -> [Word8] -> Int -> [Char]
forall {t}. (Eq t, Num t) => t -> [Word8] -> Int -> [Char]
aux Int
i [Word8]
cs (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask))
      where
        aux :: t -> [Word8] -> Int -> [Char]
aux t
0 [Word8]
rs Int
acc
          | Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc Bool -> Bool -> Bool
&& Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xd800 Bool -> Bool -> Bool
|| Int
0xdfff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)     Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xfffe Bool -> Bool -> Bool
|| Int
0xffff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)      = Int -> Char
chr Int
acc Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
rs
          | Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
rs

        aux t
n (Word8
r:[Word8]
rs) Int
acc
          | Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 = t -> [Word8] -> Int -> [Char]
aux (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [Word8]
rs
                               (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
acc Int
6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)

        aux t
_ [Word8]
rs     Int
_ = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> [Char]
decode [Word8]
rs


-- This function is a bit funny because potentially the input String could contain some actual Unicode
-- characters (though this shouldn't happen for most use cases), so we have to preserve those characters
-- while simultaneously decoding any UTF-8 data
urlDecode :: String -> String
urlDecode :: ShowS
urlDecode = [Word8] -> ShowS
go []
  where
    go :: [Word8] -> ShowS
go [Word8]
bs (Char
'%':Char
a:Char
b:[Char]
rest)           = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
digitToInt Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
b) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) [Char]
rest
    go [Word8]
bs (Char
h:[Char]
t) | Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) [Char]
t -- Treat ASCII as just another byte of UTF-8
    go [] []                       = []
    go [] (Char
h:[Char]
t)                    = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> ShowS
go [] [Char]
t -- h >= 256, so can't be part of any UTF-8 byte sequence
    go [Word8]
bs [Char]
rest                     = [Word8] -> [Char]
decode ([Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
bs) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Word8] -> ShowS
go [] [Char]
rest


urlEncode :: String -> String
urlEncode :: ShowS
urlEncode     [] = []
urlEncode (Char
ch:[Char]
t) 
  | (Char -> Bool
isAscii Char
ch Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
ch) Bool -> Bool -> Bool
|| Char
ch Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"-_.~" = Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode [Char]
t
  | Bool -> Bool
not (Char -> Bool
isAscii Char
ch) = (Word8 -> ShowS) -> [Char] -> [Word8] -> [Char]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> ShowS
escape (ShowS
urlEncode [Char]
t) (Char -> [Word8]
encodeChar Char
ch)
  | Bool
otherwise = Word8 -> ShowS
escape (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch)) (ShowS
urlEncode [Char]
t)
    where
     escape :: Word8 -> ShowS
escape Word8
b [Char]
rs = Char
'%'Char -> ShowS
forall a. a -> [a] -> [a]
:Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
16) (Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` Word8
16) [Char]
rs)

     showH :: Word8 -> String -> String
     showH :: Word8 -> ShowS
showH Word8
x [Char]
xs
       | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
9    = Word8 -> Char
to (Word8
o_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
x) Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
xs
       | Bool
otherwise = Word8 -> Char
to (Word8
o_A Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (Word8
xWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-Word8
10)) Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
xs
      where
       to :: Word8 -> Char
to  = Int -> Char
forall a. Enum a => Int -> a
toEnum  (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
       fro :: Char -> Word8
fro = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum

       o_0 :: Word8
o_0 = Char -> Word8
fro Char
'0'
       o_A :: Word8
o_A = Char -> Word8
fro Char
'A'

-- Encode form variables, useable in either the
-- query part of a URI, or the body of a POST request.
-- I have no source for this information except experience,
-- this sort of encoding worked fine in CGI programming.
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars :: [([Char], [Char])] -> [Char]
urlEncodeVars (([Char]
n,[Char]
v):[([Char], [Char])]
t) =
    let ([([Char], [Char])]
same,[([Char], [Char])]
diff) = (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> ([([Char], [Char])], [([Char], [Char])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
n) ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [Char])]
t
    in ShowS
urlEncode [Char]
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: ([Char] -> ShowS) -> [Char] -> [[Char]] -> [Char]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[Char]
x [Char]
y -> [Char]
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
',' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode [Char]
y) (ShowS
urlEncode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
v) ((([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd [([Char], [Char])]
same)
       [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
urlEncodeRest [([Char], [Char])]
diff
       where urlEncodeRest :: [([Char], [Char])] -> [Char]
urlEncodeRest [] = []
             urlEncodeRest [([Char], [Char])]
diff = Char
'&' Char -> ShowS
forall a. a -> [a] -> [a]
: [([Char], [Char])] -> [Char]
urlEncodeVars [([Char], [Char])]
diff
urlEncodeVars [] = []

-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@
-- header.
#if MIN_VERSION_base(4,13,0)
getAuth :: MonadFail m => Request ty -> m URIAuthority
#else
getAuth :: Monad m => Request ty -> m URIAuthority
#endif
getAuth :: forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
r = 
   -- ToDo: verify that Network.URI functionality doesn't take care of this (now.)
  case [Char] -> Maybe URIAuthority
parseURIAuthority [Char]
auth of
    Just URIAuthority
x -> URIAuthority -> m URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority
x 
    Maybe URIAuthority
Nothing -> [Char] -> m URIAuthority
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m URIAuthority) -> [Char] -> m URIAuthority
forall a b. (a -> b) -> a -> b
$ [Char]
"Network.HTTP.Base.getAuth: Error parsing URI authority '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
auth [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
 where 
  auth :: [Char]
auth = [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (URI -> [Char]
uriToAuthorityString URI
uri) ShowS
forall a. a -> a
id (HeaderName -> Request ty -> Maybe [Char]
forall a. HasHeaders a => HeaderName -> a -> Maybe [Char]
findHeader HeaderName
HdrHost Request ty
r)
  uri :: URI
uri  = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r

{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty
normalizeRequestURI :: forall ty. Bool -> [Char] -> Request ty -> Request ty
normalizeRequestURI Bool
doClose [Char]
h Request ty
r = 
  (if Bool
doClose then HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection [Char]
"close" else Request ty -> Request ty
forall a. a -> a
id) (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
  HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost [Char]
h (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
    Request ty
r { rqURI :: URI
rqURI = (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r){ uriScheme :: [Char]
uriScheme = [Char]
""
                         , uriAuthority :: Maybe URIAuth
uriAuthority = Maybe URIAuth
forall a. Maybe a
Nothing
                         }}

-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options
-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option
data NormalizeRequestOptions ty
 = NormalizeRequestOptions
     { forall ty. NormalizeRequestOptions ty -> Bool
normDoClose   :: Bool
     , forall ty. NormalizeRequestOptions ty -> Bool
normForProxy  :: Bool
     , forall ty. NormalizeRequestOptions ty -> Maybe [Char]
normUserAgent :: Maybe String
     , forall ty. NormalizeRequestOptions ty -> [RequestNormalizer ty]
normCustoms   :: [RequestNormalizer ty]
     }

-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites
-- a request into some normalized form.
type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty

defaultNormalizeRequestOptions :: NormalizeRequestOptions ty
defaultNormalizeRequestOptions :: forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions = NormalizeRequestOptions :: forall ty.
Bool
-> Bool
-> Maybe [Char]
-> [RequestNormalizer ty]
-> NormalizeRequestOptions ty
NormalizeRequestOptions
     { normDoClose :: Bool
normDoClose   = Bool
False
     , normForProxy :: Bool
normForProxy  = Bool
False
     , normUserAgent :: Maybe [Char]
normUserAgent = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
defaultUserAgent
     , normCustoms :: [RequestNormalizer ty]
normCustoms   = []
     }

-- | @normalizeRequest opts req@ is the entry point to use to normalize your
-- request prior to transmission (or other use.) Normalization is controlled
-- via the @NormalizeRequestOptions@ record.
normalizeRequest :: NormalizeRequestOptions ty
                 -> Request ty
                 -> Request ty
normalizeRequest :: forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest NormalizeRequestOptions ty
opts Request ty
req = ((NormalizeRequestOptions ty -> Request ty -> Request ty)
 -> Request ty -> Request ty)
-> Request ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> Request ty
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NormalizeRequestOptions ty -> Request ty -> Request ty
f -> NormalizeRequestOptions ty -> Request ty -> Request ty
f NormalizeRequestOptions ty
opts) Request ty
req [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers
 where
  --normalizers :: [RequestNormalizer ty]
  normalizers :: [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers = 
     ( NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeHostURI
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeBasicAuth
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeConnectionClose
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeUserAgent 
     (NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall ty. NormalizeRequestOptions ty -> [RequestNormalizer ty]
normCustoms NormalizeRequestOptions ty
opts
     )

-- | @normalizeUserAgent ua x req@ augments the request @req@ with 
-- a @User-Agent: ua@ header if @req@ doesn't already have a 
-- a @User-Agent:@ set.
normalizeUserAgent :: RequestNormalizer ty
normalizeUserAgent :: forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeUserAgent NormalizeRequestOptions ty
opts Request ty
req = 
  case NormalizeRequestOptions ty -> Maybe [Char]
forall ty. NormalizeRequestOptions ty -> Maybe [Char]
normUserAgent NormalizeRequestOptions ty
opts of
    Maybe [Char]
Nothing -> Request ty
req
    Just [Char]
ua -> 
     case HeaderName -> Request ty -> Maybe [Char]
forall a. HasHeaders a => HeaderName -> a -> Maybe [Char]
findHeader HeaderName
HdrUserAgent Request ty
req of
       Just [Char]
u  | [Char]
u [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
defaultUserAgent -> Request ty
req
       Maybe [Char]
_ -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrUserAgent [Char]
ua Request ty
req

-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ 
-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then
-- _replaces_ any an existing @Connection:@ header in @req@.
normalizeConnectionClose :: RequestNormalizer ty
normalizeConnectionClose :: forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeConnectionClose NormalizeRequestOptions ty
opts Request ty
req 
 | NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normDoClose NormalizeRequestOptions ty
opts = HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection [Char]
"close" Request ty
req
 | Bool
otherwise        = Request ty
req

-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@
-- if the "user:pass@" part is present in the "http://user:pass@host/path"
-- of the URI. If Authorization header was present already it is not replaced.
normalizeBasicAuth :: RequestNormalizer ty
normalizeBasicAuth :: forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeBasicAuth NormalizeRequestOptions ty
_ Request ty
req =
  case Request ty -> Maybe URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
req of
    Just URIAuthority
uriauth ->
      case (URIAuthority -> Maybe [Char]
user URIAuthority
uriauth, URIAuthority -> Maybe [Char]
password URIAuthority
uriauth) of
        (Just [Char]
u, Just [Char]
p) ->
          HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrAuthorization [Char]
astr Request ty
req
            where
              astr :: [Char]
astr = [Char]
"Basic " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
base64encode ([Char]
u [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
p)
              base64encode :: ShowS
base64encode = [Word8] -> [Char]
Base64.encode ([Word8] -> [Char]) -> ([Char] -> [Word8]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Word8]
stringToOctets :: String -> String
              stringToOctets :: [Char] -> [Word8]
stringToOctets = (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) :: String -> [Word8]
        (Maybe [Char]
_, Maybe [Char]
_) -> Request ty
req
    Maybe URIAuthority
Nothing ->Request ty
req

-- | @normalizeHostURI forProxy req@ rewrites your request to have it
-- follow the expected formats by the receiving party (proxy or server.)
-- 
normalizeHostURI :: RequestNormalizer ty
normalizeHostURI :: forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeHostURI NormalizeRequestOptions ty
opts Request ty
req = 
  case URI -> ([Char], URI)
splitRequestURI URI
uri of
    ([Char]
"",URI
_uri_abs)
      | Bool
forProxy -> 
         case HeaderName -> Request ty -> Maybe [Char]
forall a. HasHeaders a => HeaderName -> a -> Maybe [Char]
findHeader HeaderName
HdrHost Request ty
req of
           Maybe [Char]
Nothing -> Request ty
req -- no host/authority in sight..not much we can do.
           Just [Char]
h  -> Request ty
req{rqURI :: URI
rqURI=URI
uri{ uriAuthority :: Maybe URIAuth
uriAuthority=URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth :: [Char] -> [Char] -> [Char] -> URIAuth
URIAuth{uriUserInfo :: [Char]
uriUserInfo=[Char]
"", uriRegName :: [Char]
uriRegName=[Char]
hst, uriPort :: [Char]
uriPort=[Char]
pNum}
                                   , uriScheme :: [Char]
uriScheme=if ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [Char]
uriScheme URI
uri)) then [Char]
"http" else URI -> [Char]
uriScheme URI
uri
                                   }}
            where 
              hst :: [Char]
hst = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@') [Char]
user_hst of
                       ([Char]
as,Char
'@':[Char]
bs) ->
                          case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') [Char]
as of
                            ([Char]
_,Char
_:[Char]
_) -> [Char]
bs
                            ([Char], [Char])
_ -> [Char]
user_hst
                       ([Char], [Char])
_ -> [Char]
user_hst

              ([Char]
user_hst, [Char]
pNum) =
                 case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (ShowS
forall a. [a] -> [a]
reverse [Char]
h) of
                   ([Char]
ds,Char
':':[Char]
bs) -> (ShowS
forall a. [a] -> [a]
reverse [Char]
bs, Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
forall a. [a] -> [a]
reverse [Char]
ds)
                   ([Char], [Char])
_ -> ([Char]
h,[Char]
"")
      | Bool
otherwise -> 
         case HeaderName -> Request ty -> Maybe [Char]
forall a. HasHeaders a => HeaderName -> a -> Maybe [Char]
findHeader HeaderName
HdrHost Request ty
req of
           Maybe [Char]
Nothing -> Request ty
req -- no host/authority in sight..not much we can do...complain?
           Just{}  -> Request ty
req
    ([Char]
h,URI
uri_abs) 
      | Bool
forProxy  -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost [Char]
h Request ty
req 
      | Bool
otherwise -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrHost [Char]
h Request ty
req{rqURI :: URI
rqURI=URI
uri_abs} -- Note: _not_ stubbing out user:pass
 where
   uri0 :: URI
uri0     = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req 
     -- stub out the user:pass 
   uri :: URI
uri      = URI
uri0{uriAuthority :: Maybe URIAuth
uriAuthority=(URIAuth -> URIAuth) -> Maybe URIAuth -> Maybe URIAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ URIAuth
x -> URIAuth
x{uriUserInfo :: [Char]
uriUserInfo=[Char]
""}) (URI -> Maybe URIAuth
uriAuthority URI
uri0)}

   forProxy :: Bool
forProxy = NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normForProxy NormalizeRequestOptions ty
opts

{- Comments re: above rewriting:
    RFC 2616, section 5.1.2:
     "The most common form of Request-URI is that used to identify a
      resource on an origin server or gateway. In this case the absolute
      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as
      the Request-URI, and the network location of the URI (authority) MUST
      be transmitted in a Host header field." 
   We assume that this is the case, so we take the host name from
   the Host header if there is one, otherwise from the request-URI.
   Then we make the request-URI an abs_path and make sure that there
   is a Host header.
-}

splitRequestURI :: URI -> ({-authority-}String, URI)
splitRequestURI :: URI -> ([Char], URI)
splitRequestURI URI
uri = (URI -> [Char]
uriToAuthorityString URI
uri, URI
uri{uriScheme :: [Char]
uriScheme=[Char]
"", uriAuthority :: Maybe URIAuth
uriAuthority=Maybe URIAuth
forall a. Maybe a
Nothing})

-- Adds a Host header if one is NOT ALREADY PRESENT..
{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeHostHeader :: Request ty -> Request ty
normalizeHostHeader :: forall ty. Request ty -> Request ty
normalizeHostHeader Request ty
rq = 
  HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost
                        (URI -> [Char]
uriToAuthorityString (URI -> [Char]) -> URI -> [Char]
forall a b. (a -> b) -> a -> b
$ Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq)
                        Request ty
rq
                                     
-- Looks for a "Connection" header with the value "close".
-- Returns True when this is found.
findConnClose :: [Header] -> Bool
findConnClose :: [Header] -> Bool
findConnClose [Header]
hdrs =
  Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
        (\ [Char]
x -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim [Char]
x) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"close")
        (HeaderName -> [Header] -> Maybe [Char]
lookupHeader HeaderName
HdrConnection [Header]
hdrs)

-- | Used when we know exactly how many bytes to expect.
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer :: forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer Int -> IO (Result a)
readBlk Int
n = (a -> Result ([Header], a))
-> IO (Result a) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\a
str -> ([Header], a) -> Result ([Header], a)
forall a b. b -> Either a b
Right ([],a
str)) (Int -> IO (Result a)
readBlk Int
n)

-- | Used when nothing about data is known,
--   Unfortunately waiting for a socket closure
--   causes bad behaviour.  Here we just
--   take data once and give up the rest.
hopefulTransfer :: BufferOp a
                -> IO (Result a)
                -> [a]
                -> IO (Result ([Header],a))
hopefulTransfer :: forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp a
bufOps IO (Result a)
readL [a]
strs 
    = IO (Result a)
readL IO (Result a)
-> (Result a -> IO (Either ConnError ([Header], a)))
-> IO (Either ConnError ([Header], a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
      (ConnError -> IO (Either ConnError ([Header], a)))
-> (a -> IO (Either ConnError ([Header], a)))
-> Result a
-> IO (Either ConnError ([Header], a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ConnError
v -> Either ConnError ([Header], a)
-> IO (Either ConnError ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError ([Header], a)
 -> IO (Either ConnError ([Header], a)))
-> Either ConnError ([Header], a)
-> IO (Either ConnError ([Header], a))
forall a b. (a -> b) -> a -> b
$ ConnError -> Either ConnError ([Header], a)
forall a b. a -> Either a b
Left ConnError
v)
             (\a
more -> if (BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
more)
                         then Either ConnError ([Header], a)
-> IO (Either ConnError ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], a) -> Either ConnError ([Header], a)
forall a b. b -> Either a b
Right ([], BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
strs))
                         else BufferOp a
-> IO (Result a) -> [a] -> IO (Either ConnError ([Header], a))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp a
bufOps IO (Result a)
readL (a
morea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
strs))

-- | A necessary feature of HTTP\/1.1
--   Also the only transfer variety likely to
--   return any footers.
chunkedTransfer :: BufferOp a
                -> IO (Result a)
                -> (Int -> IO (Result a))
                -> IO (Result ([Header], a))
chunkedTransfer :: forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk = BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk [] Int
0

chunkedTransferC :: BufferOp a
                 -> IO (Result a)
                 -> (Int -> IO (Result a))
                 -> [a]
                 -> Int
                 -> IO (Result ([Header], a))
chunkedTransferC :: forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk [a]
acc Int
n = do
  Result a
v <- IO (Result a)
readL
  case Result a
v of
    Left ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
    Right a
line 
     | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> 
         -- last chunk read; look for trailing headers..
        ([a] -> Result ([Header], a))
-> IO (Result [a]) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\ [a]
strs -> do
                 [Header]
ftrs <- [[Char]] -> Result [Header]
parseHeaders ((a -> [Char]) -> [a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (BufferOp a -> a -> [Char]
forall a. BufferOp a -> a -> [Char]
buf_toStr BufferOp a
bufOps) [a]
strs)
                  -- insert (computed) Content-Length header.
                 let ftrs' :: [Header]
ftrs' = HeaderName -> [Char] -> Header
Header HeaderName
HdrContentLength (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
ftrs
                 ([Header], a) -> Result ([Header], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header]
ftrs',BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)))

              (BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [])

     | Bool
otherwise -> do
         Result a
some <- Int -> IO (Result a)
readBlk Int
size
         case Result a
some of
           Left ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
           Right a
cdata -> do
               Result a
_ <- IO (Result a)
readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?
               BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk (a
cdataa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size)
     where
      size :: Int
size 
       | BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
line = Int
0
       | Bool
otherwise = 
         case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex (BufferOp a -> a -> [Char]
forall a. BufferOp a -> a -> [Char]
buf_toStr BufferOp a
bufOps a
line) of
          (Int
hx,[Char]
_):[(Int, [Char])]
_ -> Int
hx
          [(Int, [Char])]
_        -> Int
0

-- | Maybe in the future we will have a sensible thing
--   to do here, at that time we might want to change
--   the name.
uglyDeathTransfer :: String -> IO (Result ([Header],a))
uglyDeathTransfer :: forall a. [Char] -> IO (Result ([Header], a))
uglyDeathTransfer [Char]
loc = Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char] -> Result ([Header], a)
forall a. [Char] -> [Char] -> Result a
responseParseError [Char]
loc [Char]
"Unknown Transfer-Encoding")

-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
readTillEmpty1 :: BufferOp a
               -> IO (Result a)
               -> IO (Result [a])
readTillEmpty1 :: forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp a
bufOps IO (Result a)
readL =
  IO (Result a)
readL IO (Result a)
-> (Result a -> IO (Either ConnError [a]))
-> IO (Either ConnError [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (ConnError -> IO (Either ConnError [a]))
-> (a -> IO (Either ConnError [a]))
-> Result a
-> IO (Either ConnError [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ConnError [a] -> IO (Either ConnError [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError [a] -> IO (Either ConnError [a]))
-> (ConnError -> Either ConnError [a])
-> ConnError
-> IO (Either ConnError [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Either ConnError [a]
forall a b. a -> Either a b
Left)
           (\ a
s -> 
               if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s
                then BufferOp a -> IO (Result a) -> IO (Either ConnError [a])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp a
bufOps IO (Result a)
readL
                else BufferOp a -> IO (Result a) -> [a] -> IO (Either ConnError [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [a
s])

-- | Read lines until an empty line (CRLF),
--   also accepts a connection close as end of
--   input, which is not an HTTP\/1.1 compliant
--   thing to do - so probably indicates an
--   error condition.
readTillEmpty2 :: BufferOp a
               -> IO (Result a)
               -> [a]
               -> IO (Result [a])
readTillEmpty2 :: forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [a]
list =
    IO (Result a)
readL IO (Result a)
-> (Result a -> IO (Either ConnError [a]))
-> IO (Either ConnError [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      (ConnError -> IO (Either ConnError [a]))
-> (a -> IO (Either ConnError [a]))
-> Result a
-> IO (Either ConnError [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ConnError [a] -> IO (Either ConnError [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError [a] -> IO (Either ConnError [a]))
-> (ConnError -> Either ConnError [a])
-> ConnError
-> IO (Either ConnError [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Either ConnError [a]
forall a b. a -> Either a b
Left)
             (\ a
s ->
                if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s Bool -> Bool -> Bool
|| BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
s
                 then Either ConnError [a] -> IO (Either ConnError [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Either ConnError [a]
forall a b. b -> Either a b
Right ([a] -> Either ConnError [a]) -> [a] -> Either ConnError [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list))
                 else BufferOp a -> IO (Result a) -> [a] -> IO (Either ConnError [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list))

--
-- Misc
--

-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific
-- tweaks better go here.
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO :: forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO a
a IOException -> IO a
h = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch IO a
a IOException -> IO a
h

catchIO_ :: IO a -> IO a -> IO a
catchIO_ :: forall a. IO a -> IO a -> IO a
catchIO_ IO a
a IO a
h = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch IO a
a (\(IOException
_ :: IOException) -> IO a
h)

responseParseError :: String -> String -> Result a
responseParseError :: forall a. [Char] -> [Char] -> Result a
responseParseError [Char]
loc [Char]
v = ConnError -> Result a
forall a. ConnError -> Result a
failWith ([Char] -> ConnError
ErrorParse ([Char]
loc [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:[Char]
v))