-- -----------------------------------------------------------------------------
-- 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.Response where

import qualified Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.Stream as Stream
import Network.MoHWS.HTTP.Header (HasHeaders, )
import Network.MoHWS.ParserUtility (crLf, )
import Network.MoHWS.Utility (formatTimeSensibly, hPutStrCrLf, )

import Control.Monad.Trans.State (state, evalState, get, )
import Data.Tuple.HT (swap, )

import qualified Network.HTTP.Base as HTTP
import qualified Network.HTTP.Headers
   -- make getHeaders visible for instance declaration
import Network.URI (URI, )

import qualified Data.Map as Map

import qualified Control.Exception as Exception
import qualified System.IO as IO
import System.Time (getClockTime, toUTCTime, )
import qualified Text.Html as Html
import Text.Html (Html, renderHtml, toHtml, noHtml, (+++), (<<), )


-----------------------------------------------------------------------------
-- Responses

data Body body =
   Body {
      -- e.g. filename of content
      Body body -> String
source  :: String,
      Body body -> Maybe Integer
size    :: Maybe Integer,
      Body body -> IO ()
close   :: IO (),
      Body body -> body
content :: body
   }

data T body =
   Cons {
      T body -> Int
code         :: Int,
      T body -> String
description  :: String,
      T body -> Group
headers      :: Header.Group,
      T body -> [TransferCoding]
coding       :: [Header.TransferCoding],
         {- either empty or terminated with ChunkedTransferEncoding
            (RFC2616, sec 3.6) -}
      T body -> Bool
doSendBody   :: Bool,
         {- actually send the body?
            (False for HEAD requests) -}
      T body -> Body body
body         :: Body body
   }

instance Functor Body where
   fmap :: (a -> b) -> Body a -> Body b
fmap a -> b
f Body a
bdy =
      Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Body {
         source :: String
source  =     Body a -> String
forall body. Body body -> String
source  Body a
bdy,
         size :: Maybe Integer
size    =     Body a -> Maybe Integer
forall body. Body body -> Maybe Integer
size    Body a
bdy,
         close :: IO ()
close   =     Body a -> IO ()
forall body. Body body -> IO ()
close   Body a
bdy,
         content :: b
content = a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Body a -> a
forall body. Body body -> body
content Body a
bdy
      }

instance Functor T where
   fmap :: (a -> b) -> T a -> T b
fmap a -> b
f T a
resp =
      Cons :: forall body.
Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
Cons {
         code :: Int
code        =          T a -> Int
forall body. T body -> Int
code        T a
resp,
         description :: String
description =          T a -> String
forall body. T body -> String
description T a
resp,
         headers :: Group
headers     =          T a -> Group
forall body. T body -> Group
headers     T a
resp,
         coding :: [TransferCoding]
coding      =          T a -> [TransferCoding]
forall body. T body -> [TransferCoding]
coding      T a
resp,
         doSendBody :: Bool
doSendBody  =          T a -> Bool
forall body. T body -> Bool
doSendBody  T a
resp,
         body :: Body b
body        = (a -> b) -> Body a -> Body b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Body a -> Body b) -> Body a -> Body b
forall a b. (a -> b) -> a -> b
$ T a -> Body a
forall body. T body -> Body body
body        T a
resp
      }

decomposeCode :: Int -> HTTP.ResponseCode
decomposeCode :: Int -> ResponseCode
decomposeCode =
   let getDigit :: StateT Int Identity Int
getDigit = (Int -> (Int, Int)) -> StateT Int Identity Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int -> (Int, Int)) -> StateT Int Identity Int)
-> (Int -> (Int, Int)) -> StateT Int Identity Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap ((Int, Int) -> (Int, Int))
-> (Int -> (Int, Int)) -> Int -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
10
   in  State Int ResponseCode -> Int -> ResponseCode
forall s a. State s a -> s -> a
evalState (State Int ResponseCode -> Int -> ResponseCode)
-> State Int ResponseCode -> Int -> ResponseCode
forall a b. (a -> b) -> a -> b
$
          do Int
c <- StateT Int Identity Int
getDigit
             Int
b <- StateT Int Identity Int
getDigit
             Int
a <- StateT Int Identity Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
             ResponseCode -> State Int ResponseCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a,Int
b,Int
c)

toHTTPbis :: T body -> HTTP.Response body
toHTTPbis :: T body -> Response body
toHTTPbis T body
resp =
   Response :: forall a. ResponseCode -> String -> [Header] -> a -> Response a
HTTP.Response {
      rspCode :: ResponseCode
HTTP.rspCode    = Int -> ResponseCode
decomposeCode (T body -> Int
forall body. T body -> Int
code T body
resp),
      rspReason :: String
HTTP.rspReason  = T body -> String
forall body. T body -> String
description T body
resp,
      rspHeaders :: [Header]
HTTP.rspHeaders = 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
resp,
      rspBody :: body
HTTP.rspBody    = Body body -> body
forall body. Body body -> body
content (Body body -> body) -> Body body -> body
forall a b. (a -> b) -> a -> b
$ T body -> Body body
forall body. T body -> Body body
body T body
resp
   }

fromHTTPbis :: HTTP.Response body -> T body
fromHTTPbis :: Response body -> T body
fromHTTPbis Response body
resp =
   Cons :: forall body.
Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
Cons {
      code :: Int
code         =
         let (Int
a,Int
b,Int
c) = Response body -> ResponseCode
forall a. Response a -> ResponseCode
HTTP.rspCode Response body
resp
         in  (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
b)Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
c,
      description :: String
description  = Response body -> String
forall a. Response a -> String
HTTP.rspReason Response body
resp,
      headers :: Group
headers      = [Header] -> Group
Header.group ([Header] -> Group) -> [Header] -> Group
forall a b. (a -> b) -> a -> b
$ Response body -> [Header]
forall a. Response a -> [Header]
HTTP.rspHeaders Response body
resp,
      coding :: [TransferCoding]
coding       = [],
      doSendBody :: Bool
doSendBody   = Bool
True,
      body :: Body body
body         =
         Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Body {
            source :: String
source = String
"HTTPbis response",
            size :: Maybe Integer
size = Maybe Integer
forall a. Maybe a
Nothing,
            close :: IO ()
close = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
            content :: body
content = Response body -> body
forall a. Response a -> a
HTTP.rspBody Response body
resp
         }
   }


instance Show (T body) where
   showsPrec :: Int -> T body -> ShowS
showsPrec Int
_ T body
r =
      String -> ShowS
showString (T body -> String
forall body. T body -> String
showStatusLine T body
r) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
crLf ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Group -> ShowS
forall a. Show a => a -> ShowS
shows (T body -> Group
forall body. T body -> Group
headers T body
r)

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
resp [Header]
hs = T body
resp { headers :: Group
headers = [Header] -> Group
Header.group [Header]
hs}

showStatusLine :: T body -> String
showStatusLine :: T body -> String
showStatusLine (Cons Int
s String
desc Group
_ [TransferCoding]
_ Bool
_ Body body
_) = Int -> String
forall a. Show a => a -> String
show Int
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
desc


hasBody :: (Stream.C body) => Body body -> Bool
hasBody :: Body body -> Bool
hasBody = Bool -> Bool
not (Bool -> Bool) -> (Body body -> Bool) -> Body body -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. body -> Bool
forall stream. C stream => stream -> Bool
Stream.isEmpty (body -> Bool) -> (Body body -> body) -> Body body -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body body -> body
forall body. Body body -> body
content

getFileName :: Body body -> String
getFileName :: Body body -> String
getFileName = Body body -> String
forall body. Body body -> String
source

sendBody :: (Stream.C body) => IO.Handle -> Body body -> IO ()
sendBody :: Handle -> Body body -> IO ()
sendBody Handle
h Body body
b =
   IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
Exception.finally
     (do Handle -> body -> IO ()
forall stream. C stream => Handle -> stream -> IO ()
Stream.write Handle
h (body -> IO ()) -> body -> IO ()
forall a b. (a -> b) -> a -> b
$ Body body -> body
forall body. Body body -> body
content Body body
b
         Handle -> IO ()
IO.hFlush Handle
h)
     {-
     It is only safe to close the source
     after all lazily read data is written.
     -}
     (Body body -> IO ()
forall body. Body body -> IO ()
close Body body
b)

sendBodyChunked :: (Stream.C body) =>
   Int -> IO.Handle -> Body body -> IO ()
sendBodyChunked :: Int -> Handle -> Body body -> IO ()
sendBodyChunked Int
chunkSize Handle
h Body body
b =
   IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
Exception.finally
     (do Int -> Handle -> body -> IO ()
forall stream. C stream => Int -> Handle -> stream -> IO ()
Stream.writeChunked Int
chunkSize Handle
h (body -> IO ()) -> body -> IO ()
forall a b. (a -> b) -> a -> b
$ Body body -> body
forall body. Body body -> body
content Body body
b
         Handle -> String -> IO ()
hPutStrCrLf Handle
h String
"0"
         Handle -> String -> IO ()
hPutStrCrLf Handle
h String
""
         Handle -> IO ()
IO.hFlush Handle
h)
     {-
     It is only safe to close the source
     after all lazily read data is written.
     -}
     (Body body -> IO ()
forall body. Body body -> IO ()
close Body body
b)


-- only allowed in chunked coding
bodyFromString :: (Stream.C body) => body -> Body body
bodyFromString :: body -> Body body
bodyFromString body
str =
   Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Body {
      source :: String
source = String
"<generated>",
      size :: Maybe Integer
size = Maybe Integer
forall a. Maybe a
Nothing,
      close :: IO ()
close = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      content :: body
content = body
str
   }

bodyWithSizeFromString :: (Stream.C body) => body -> Body body
bodyWithSizeFromString :: body -> Body body
bodyWithSizeFromString body
str =
   Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Body {
      source :: String
source = String
"<generated>",
      size :: Maybe Integer
size = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ body -> Integer
forall stream. C stream => stream -> Integer
Stream.length body
str,
      close :: IO ()
close = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
      content :: body
content = body
str
   }

statusLine :: Int -> String -> String
statusLine :: Int -> ShowS
statusLine Int
cde String
desc = String
httpVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
cde String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
: String
desc

httpVersion :: String
httpVersion :: String
httpVersion = String
"HTTP/1.1"


-----------------------------------------------------------------------------
-- Response Header.Group

dateHeader :: IO Header.T
dateHeader :: IO Header
dateHeader = do
   -- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC
  (ClockTime -> Header) -> IO ClockTime -> IO Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
     (Name -> String -> Header
Header.make Name
Header.HdrDate (String -> Header) -> (ClockTime -> String) -> ClockTime -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      CalendarTime -> String
formatTimeSensibly (CalendarTime -> String)
-> (ClockTime -> CalendarTime) -> ClockTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ClockTime -> CalendarTime
toUTCTime)
     IO ClockTime
getClockTime

serverHeader :: Header.T
serverHeader :: Header
serverHeader =
   Name -> String -> Header
Header.make Name
Header.HdrServer (String -> Header) -> String -> Header
forall a b. (a -> b) -> a -> b
$
   String
Config.serverSoftware String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:String
Config.serverVersion


-----------------------------------------------------------------------------
-- Response codes

makeCont :: (Stream.C body) => Config.T ext -> T body
makeCont :: T ext -> T body
makeCont                         = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
100
makeSwitchingProtocols :: (Stream.C body) => Config.T ext -> T body
makeSwitchingProtocols :: T ext -> T body
makeSwitchingProtocols           = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
101
makeOk :: Config.T ext -> Bool -> Header.Group -> Body body -> T body
makeOk :: T ext -> Bool -> Group -> Body body -> T body
makeOk                           = Int -> T ext -> Bool -> Group -> Body body -> T body
forall ext body.
Int -> T ext -> Bool -> Group -> Body body -> T body
makeWithBody Int
200
makeCreated :: (Stream.C body) => Config.T ext -> T body
makeCreated :: T ext -> T body
makeCreated                      = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
201
makeAccepted :: (Stream.C body) => Config.T ext -> T body
makeAccepted :: T ext -> T body
makeAccepted                     = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
202
makeNonAuthoritiveInformation :: (Stream.C body) => Config.T ext -> T body
makeNonAuthoritiveInformation :: T ext -> T body
makeNonAuthoritiveInformation    = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
203
makeNoContent :: (Stream.C body) => Config.T ext -> T body
makeNoContent :: T ext -> T body
makeNoContent                    = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
204
makeResetContent :: (Stream.C body) => Config.T ext -> T body
makeResetContent :: T ext -> T body
makeResetContent                 = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
205
makePartialContent :: (Stream.C body) => Config.T ext -> T body
makePartialContent :: T ext -> T body
makePartialContent               = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
206
makeMultipleChoices :: (Stream.C body) => Config.T ext -> T body
makeMultipleChoices :: T ext -> T body
makeMultipleChoices              = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
300
makeMovedPermanently :: Config.T ext -> Header.Group -> Body body -> URI -> T body
makeMovedPermanently :: T ext -> Group -> Body body -> URI -> T body
makeMovedPermanently T ext
conf Group
hdrs Body body
bdy URI
uri =
   Int -> T ext -> Bool -> Group -> Body body -> T body
forall ext body.
Int -> T ext -> Bool -> Group -> Body body -> T body
makeWithBody Int
301 T ext
conf Bool
True
      (([Header] -> [Header]) -> Group -> Group
forall x. HasHeaders x => ([Header] -> [Header]) -> x -> x
Header.modifyMany (URI -> Header
Header.makeLocation URI
uri Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:) Group
hdrs) Body body
bdy
makeFound :: (Stream.C body) => Config.T ext -> T body
makeFound :: T ext -> T body
makeFound                        = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
302
makeSeeOther :: (Stream.C body) => Config.T ext -> T body
makeSeeOther :: T ext -> T body
makeSeeOther                     = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
303
makeNotModified :: (Stream.C body) => Config.T ext -> T body
makeNotModified :: T ext -> T body
makeNotModified                  = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
304
makeUseProxy :: (Stream.C body) => Config.T ext -> T body
makeUseProxy :: T ext -> T body
makeUseProxy                     = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
305
makeTemporaryRedirect :: (Stream.C body) => Config.T ext -> T body
makeTemporaryRedirect :: T ext -> T body
makeTemporaryRedirect            = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
307
makeBadRequest :: (Stream.C body) => Config.T ext -> T body
makeBadRequest :: T ext -> T body
makeBadRequest                   = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
400
makeUnauthorized :: (Stream.C body) => Config.T ext -> T body
makeUnauthorized :: T ext -> T body
makeUnauthorized                 = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
401
makePaymentRequired :: (Stream.C body) => Config.T ext -> T body
makePaymentRequired :: T ext -> T body
makePaymentRequired              = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
402
makeForbidden :: (Stream.C body) => Config.T ext -> T body
makeForbidden :: T ext -> T body
makeForbidden                    = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
403
makeNotFound :: (Stream.C body) => Config.T ext -> T body
makeNotFound :: T ext -> T body
makeNotFound                     = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
404
makeMethodNotAllowed :: (Stream.C body) => Config.T ext -> T body
makeMethodNotAllowed :: T ext -> T body
makeMethodNotAllowed             = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
405
makeNotAcceptable :: (Stream.C body) => Config.T ext -> T body
makeNotAcceptable :: T ext -> T body
makeNotAcceptable                = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
406
makeProxyAuthenticationRequired :: (Stream.C body) => Config.T ext -> T body
makeProxyAuthenticationRequired :: T ext -> T body
makeProxyAuthenticationRequired  = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
407
makeRequestTimeOut :: (Stream.C body) => Config.T ext -> T body
makeRequestTimeOut :: T ext -> T body
makeRequestTimeOut               = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
408
makeConflict :: (Stream.C body) => Config.T ext -> T body
makeConflict :: T ext -> T body
makeConflict                     = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
409
makeGone :: (Stream.C body) => Config.T ext -> T body
makeGone :: T ext -> T body
makeGone                         = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
410
makeLengthRequired :: (Stream.C body) => Config.T ext -> T body
makeLengthRequired :: T ext -> T body
makeLengthRequired               = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
411
makePreconditionFailed :: (Stream.C body) => Config.T ext -> T body
makePreconditionFailed :: T ext -> T body
makePreconditionFailed           = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
412
makeRequestEntityTooLarge :: (Stream.C body) => Config.T ext -> T body
makeRequestEntityTooLarge :: T ext -> T body
makeRequestEntityTooLarge        = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
413
makeRequestURITooLarge :: (Stream.C body) => Config.T ext -> T body
makeRequestURITooLarge :: T ext -> T body
makeRequestURITooLarge           = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
414
makeUnsupportedMediaType :: (Stream.C body) => Config.T ext -> T body
makeUnsupportedMediaType :: T ext -> T body
makeUnsupportedMediaType         = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
415
makeRequestedRangeNotSatisfiable :: (Stream.C body) => Config.T ext -> T body
makeRequestedRangeNotSatisfiable :: T ext -> T body
makeRequestedRangeNotSatisfiable = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
416
makeExpectationFailed :: (Stream.C body) => Config.T ext -> T body
makeExpectationFailed :: T ext -> T body
makeExpectationFailed            = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
417
makeInternalServerError :: (Stream.C body) => Config.T ext -> T body
makeInternalServerError :: T ext -> T body
makeInternalServerError          = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
500
makeNotImplemented :: (Stream.C body) => Config.T ext -> T body
makeNotImplemented :: T ext -> T body
makeNotImplemented               = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
501
makeBadGateway :: (Stream.C body) => Config.T ext -> T body
makeBadGateway :: T ext -> T body
makeBadGateway                   = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
502
makeServiceUnavailable :: (Stream.C body) => Config.T ext -> T body
makeServiceUnavailable :: T ext -> T body
makeServiceUnavailable           = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
503
makeGatewayTimeOut :: (Stream.C body) => Config.T ext -> T body
makeGatewayTimeOut :: T ext -> T body
makeGatewayTimeOut               = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
504
makeVersionNotSupported :: (Stream.C body) => Config.T ext -> T body
makeVersionNotSupported :: T ext -> T body
makeVersionNotSupported          = Int -> T ext -> T body
forall body ext. C body => Int -> T ext -> T body
makeError Int
505

descriptionDictionary :: Map.Map Int String
descriptionDictionary :: Map Int String
descriptionDictionary =
   [(Int, String)] -> Map Int String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, String)] -> Map Int String)
-> [(Int, String)] -> Map Int String
forall a b. (a -> b) -> a -> b
$

   (Int
100, String
"Continue") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
101, String
"Switching Protocols") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:

   (Int
200, String
"OK") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
201, String
"Created") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
202, String
"Accepted") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
203, String
"Non-Authoritative Information") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
204, String
"No Content") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
205, String
"Reset Content") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
206, String
"Partial Content") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:

   (Int
300, String
"Multiple Choices") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
301, String
"Moved Permanently") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
302, String
"Found") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
303, String
"See Other") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
304, String
"Not Modified") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
305, String
"Use Proxy") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
307, String
"Temporary Redirect") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:

   (Int
400, String
"Bad Request") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
401, String
"Unauthorized") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
402, String
"Payment Required") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
403, String
"Forbidden") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
404, String
"Not Found") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
405, String
"Method Not Allowed") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
406, String
"Not Acceptable") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
407, String
"Proxy Authentication Required") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
408, String
"Request Time-out") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
409, String
"Conflict") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
410, String
"Gone") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
411, String
"Length Required") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
412, String
"Precondition Failed") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
413, String
"Request Entity Too Large") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
414, String
"Request-URI Too Large") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
415, String
"Unsupported Media Type") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
416, String
"Requested range not satisfiable") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
417, String
"Expectation Failed") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:

   (Int
500, String
"Internal Server Error") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
501, String
"Not Implemented") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
502, String
"Bad Gateway") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
503, String
"Service Unavailable") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
504, String
"Gateway Time-out") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   (Int
505, String
"HTTP Version not supported") (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:
   []

descriptionFromCode :: Int -> String
descriptionFromCode :: Int -> String
descriptionFromCode Int
c =
   String -> Int -> Map Int String -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault String
"Unknown response" Int
c Map Int String
descriptionDictionary

makeError :: (Stream.C body) =>
   Int -> Config.T ext -> T body
makeError :: Int -> T ext -> T body
makeError Int
cde T ext
conf =
   Int -> T ext -> Bool -> Group -> Body body -> T body
forall ext body.
Int -> T ext -> Bool -> Group -> Body body -> T body
makeWithBody Int
cde T ext
conf Bool
True
      ([Header] -> Group
Header.group [String -> Header
Header.makeContentType String
"text/html"])
      (Int -> T ext -> Body body
forall body ext. C body => Int -> T ext -> Body body
generateErrorPage Int
cde T ext
conf)

makeWithBody :: Int -> Config.T ext -> Bool -> Header.Group -> Body body -> T body
makeWithBody :: Int -> T ext -> Bool -> Group -> Body body -> T body
makeWithBody Int
cde T ext
_conf Bool
doSend Group
hdrs Body body
bdy =
   Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
forall body.
Int
-> String
-> Group
-> [TransferCoding]
-> Bool
-> Body body
-> T body
Cons Int
cde (Int -> String
descriptionFromCode Int
cde) Group
hdrs [] Bool
doSend Body body
bdy

-----------------------------------------------------------------------------
-- Error pages

-- We generate some html for the client to display on an error.

generateErrorPage :: (Stream.C body) =>
   Int -> Config.T ext -> Body body
generateErrorPage :: Int -> T ext -> Body body
generateErrorPage Int
cde T ext
conf =
   body -> Body body
forall body. C body => body -> Body body
bodyWithSizeFromString (body -> Body body) -> body -> Body body
forall a b. (a -> b) -> a -> b
$ Int -> String -> body
forall stream. C stream => Int -> String -> stream
Stream.fromString (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) (String -> body) -> String -> body
forall a b. (a -> b) -> a -> b
$
   Html -> String
forall html. HTML html => html -> String
renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$ Int -> T ext -> Html
forall ext. Int -> T ext -> Html
genErrorHtml Int
cde T ext
conf

genErrorHtml :: Int -> Config.T ext -> Html
genErrorHtml :: Int -> T ext -> Html
genErrorHtml Int
cde T ext
conf =
   let statusLn :: Html
statusLn =
          Int -> String
forall a. Show a => a -> String
show Int
cde String -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char
' ' Char -> String -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Int -> String
descriptionFromCode Int
cde
   in  Html -> Html
Html.header (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
Html.thetitle (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
statusLn
         Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html -> Html
Html.body (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
              (Html -> Html
Html.h1 (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
statusLn
               Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
Html.hr
               Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ String
Config.serverSoftware String -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char
'/' Char -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ String
Config.serverVersion
               -- ToDo: use real hostname if we don't have a serverName
               String -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ case T ext -> String
forall ext. T ext -> String
Config.serverName T ext
conf of
                     String
"" -> Html
noHtml
                     String
me -> String
" on " String -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ String
me String -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
Html.br
               Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ case T ext -> String
forall ext. T ext -> String
Config.serverAdmin T ext
conf of
                     String
"" -> Html
noHtml
                     String
her -> String
"Server Admin: " String -> HotLink -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                            String -> [Html] -> HotLink
Html.hotlink (String
"mailto:"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
her) [String -> Html
forall a. HTML a => a -> Html
toHtml String
her]
              )