Header.hs

{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, CPP #-}
module Network.HTTP.Types.Header
(
  -- ** Types
  Header
, HeaderName
, RequestHeaders
, ResponseHeaders
  -- ** Common headers
, hAccept
, hAcceptCharset
, hAcceptEncoding
, hAcceptLanguage
, hAcceptRanges
, hAge
, hAllow
, hAuthorization
, hCacheControl
, hConnection
, hContentEncoding
, hContentLanguage
, hContentLength
, hContentLocation
, hContentMD5
, hContentRange
, hContentType
, hDate
, hETag
, hExpect
, hExpires
, hFrom
, hHost
, hIfMatch
, hIfModifiedSince
, hIfNoneMatch
, hIfRange
, hIfUnmodifiedSince
, hLastModified
, hLocation
, hMaxForwards
, hOrigin
, hPragma
, hPrefer
, hPreferenceApplied
, hProxyAuthenticate
, hProxyAuthorization
, hRange
, hReferer
, hRetryAfter
, hServer
, hTE
, hTrailer
, hTransferEncoding
, hUpgrade
, hUserAgent
, hVary
, hVia
, hWWWAuthenticate
, hWarning
, hContentDisposition
, hMIMEVersion
, hCookie
, hSetCookie
  -- ** Byte ranges
, ByteRange(..)
, renderByteRangeBuilder
, renderByteRange
, ByteRanges
, renderByteRangesBuilder
, renderByteRanges
, parseByteRanges
)
where

import           Data.List
#if __GLASGOW_HASKELL__ < 710
import           Data.Monoid
#endif
import qualified Data.ByteString                as B
import qualified Data.ByteString.Char8          as B8
import qualified Data.ByteString.Builder        as B
import qualified Data.ByteString.Lazy           as BL
import qualified Data.CaseInsensitive           as CI
import           Data.ByteString.Char8          () {-IsString-}
import           Data.Typeable                  (Typeable)
import           Data.Data                      (Data)

-- | Header
type Header = (HeaderName, B.ByteString)

-- | Header name
type HeaderName = CI.CI B.ByteString

-- | Request Headers
type RequestHeaders = [Header]

-- | Response Headers
type ResponseHeaders = [Header]

-- | HTTP Header names according to http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html
hAccept, hAcceptCharset, hAcceptEncoding, hAcceptLanguage, hAcceptRanges, hAge, hAllow, hAuthorization, hCacheControl, hConnection, hContentEncoding, hContentLanguage, hContentLength, hContentLocation, hContentMD5, hContentRange, hContentType, hDate, hETag, hExpect, hExpires, hFrom, hHost, hIfMatch, hIfModifiedSince, hIfNoneMatch, hIfRange, hIfUnmodifiedSince, hLastModified, hLocation, hMaxForwards, hPragma, hProxyAuthenticate, hProxyAuthorization, hRange, hReferer, hRetryAfter, hServer, hTE, hTrailer, hTransferEncoding, hUpgrade, hUserAgent, hVary, hVia, hWWWAuthenticate, hWarning :: HeaderName
hAccept             = "Accept"
hAcceptCharset      = "Accept-Charset"
hAcceptEncoding     = "Accept-Encoding"
hAcceptLanguage     = "Accept-Language"
hAcceptRanges       = "Accept-Ranges"
hAge                = "Age"
hAllow              = "Allow"
hAuthorization      = "Authorization"
hCacheControl       = "Cache-Control"
hConnection         = "Connection"
hContentEncoding    = "Content-Encoding"
hContentLanguage    = "Content-Language"
hContentLength      = "Content-Length"
hContentLocation    = "Content-Location"
hContentMD5         = "Content-MD5"
hContentRange       = "Content-Range"
hContentType        = "Content-Type"
hDate               = "Date"
hETag               = "ETag"
hExpect             = "Expect"
hExpires            = "Expires"
hFrom               = "From"
hHost               = "Host"
hIfMatch            = "If-Match"
hIfModifiedSince    = "If-Modified-Since"
hIfNoneMatch        = "If-None-Match"
hIfRange            = "If-Range"
hIfUnmodifiedSince  = "If-Unmodified-Since"
hLastModified       = "Last-Modified"
hLocation           = "Location"
hMaxForwards        = "Max-Forwards"
hPragma             = "Pragma"
hProxyAuthenticate  = "Proxy-Authenticate"
hProxyAuthorization = "Proxy-Authorization"
hRange              = "Range"
hReferer            = "Referer"
hRetryAfter         = "Retry-After"
hServer             = "Server"
hTE                 = "TE"
hTrailer            = "Trailer"
hTransferEncoding   = "Transfer-Encoding"
hUpgrade            = "Upgrade"
hUserAgent          = "User-Agent"
hVary               = "Vary"
hVia                = "Via"
hWWWAuthenticate    = "WWW-Authenticate"
hWarning            = "Warning"

-- | HTTP Header names according to http://www.w3.org/Protocols/rfc2616/rfc2616-sec19.html
hContentDisposition, hMIMEVersion :: HeaderName
hContentDisposition = "Content-Disposition"
hMIMEVersion        = "MIME-Version"

-- | HTTP Header names according to https://tools.ietf.org/html/rfc6265#section-4
hCookie, hSetCookie :: HeaderName
hCookie             = "Cookie"
hSetCookie          = "Set-Cookie"

-- | HTTP Header names according to https://tools.ietf.org/html/rfc6454
hOrigin :: HeaderName
hOrigin = "Origin"

-- | HTTP Header names according to https://tools.ietf.org/html/rfc7240
hPrefer, hPreferenceApplied :: HeaderName
hPrefer = "Prefer"
hPreferenceApplied = "Preference-Applied"

-- | RFC 2616 Byte range (individual).
--
-- Negative indices are not allowed!
data ByteRange
  = ByteRangeFrom !Integer
  | ByteRangeFromTo !Integer !Integer
  | ByteRangeSuffix !Integer
  deriving (Show, Eq, Ord, Typeable, Data)

renderByteRangeBuilder :: ByteRange -> B.Builder
renderByteRangeBuilder (ByteRangeFrom from) = B.integerDec from `mappend` B.char7 '-'
renderByteRangeBuilder (ByteRangeFromTo from to) = B.integerDec from `mappend` B.char7 '-' `mappend` B.integerDec to
renderByteRangeBuilder (ByteRangeSuffix suffix) = B.char7 '-' `mappend` B.integerDec suffix

renderByteRange :: ByteRange -> B.ByteString
renderByteRange = BL.toStrict . B.toLazyByteString . renderByteRangeBuilder

-- | RFC 2616 Byte ranges (set).
type ByteRanges = [ByteRange]

renderByteRangesBuilder :: ByteRanges -> B.Builder
renderByteRangesBuilder xs = B.byteString "bytes=" `mappend`
                             mconcat (intersperse (B.char7 ',') (map renderByteRangeBuilder xs))

renderByteRanges :: ByteRanges -> B.ByteString
renderByteRanges = BL.toStrict . B.toLazyByteString . renderByteRangesBuilder

-- | Parse the value of a Range header into a 'ByteRanges'.
--
-- >>> parseByteRanges "error"
-- Nothing
-- >>> parseByteRanges "bytes=0-499"
-- Just [ByteRangeFromTo 0 499]
-- >>> parseByteRanges "bytes=500-999"
-- Just [ByteRangeFromTo 500 999]
-- >>> parseByteRanges "bytes=-500"
-- Just [ByteRangeSuffix 500]
-- >>> parseByteRanges "bytes=9500-"
-- Just [ByteRangeFrom 9500]
-- >>> parseByteRanges "bytes=0-0,-1"
-- Just [ByteRangeFromTo 0 0,ByteRangeSuffix 1]
-- >>> parseByteRanges "bytes=500-600,601-999"
-- Just [ByteRangeFromTo 500 600,ByteRangeFromTo 601 999]
-- >>> parseByteRanges "bytes=500-700,601-999"
-- Just [ByteRangeFromTo 500 700,ByteRangeFromTo 601 999]
parseByteRanges :: B.ByteString -> Maybe ByteRanges
parseByteRanges bs1 = do
    bs2 <- stripPrefixB "bytes=" bs1
    (r, bs3) <- range bs2
    ranges (r:) bs3
  where
    range bs2 = do
        (i, bs3) <- B8.readInteger bs2
        if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
            then Just (ByteRangeSuffix (negate i), bs3)
            else do
                bs4 <- stripPrefixB "-" bs3
                case B8.readInteger bs4 of
                    Just (j, bs5) | j >= i -> Just (ByteRangeFromTo i j, bs5)
                    _ -> Just (ByteRangeFrom i, bs4)
    ranges front bs3
        | B.null bs3 = Just (front [])
        | otherwise = do
            bs4 <- stripPrefixB "," bs3
            (r, bs5) <- range bs4
            ranges (front . (r:)) bs5

    stripPrefixB x y
        | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)
        | otherwise = Nothing