0 | module HTTP.Header
  1 |
  2 | import Data.Buffer
  3 | import Data.ByteString
  4 | import Data.SortedMap as SM
  5 | import Data.String
  6 | import HTTP.Parser.Header
  7 | import Text.ILex
  8 | import Text.ILex.DStack
  9 |
 10 | import public HTTP.Header.Types
 11 |
 12 | %hide Data.Linear.(.)
 13 | %default total
 14 |
 15 | export
 16 | record Headers where
 17 |   constructor MkHeaders
 18 |   headers : HeaderMap
 19 |
 20 | ||| Converts a set of HTTP headers to a list of name-value pairs.
 21 | export %inline
 22 | kvList : Headers -> List (String,ByteString)
 23 | kvList = kvList . headers
 24 |
 25 | export %inline
 26 | emptyHeaders : Headers
 27 | emptyHeaders = MkHeaders empty
 28 |
 29 | ||| Inserts a name-value pair into a set of header.
 30 | |||
 31 | ||| Since HTTP header names are case-insensitive, the name
 32 | ||| will be converted to all upper-case letters.
 33 | export %inline
 34 | insertHeader : (name : String) -> ByteString -> Headers -> Headers
 35 | insertHeader name value = {headers $= insert (toUpper name) value}
 36 |
 37 | ||| Looks up the header of the given name.
 38 | |||
 39 | ||| `name` has to be in all upper-case letters.
 40 | export %inline
 41 | lookupUpperCaseHeader : (name : String) -> Headers -> Maybe ByteString
 42 | lookupUpperCaseHeader n = lookup n . headers
 43 |
 44 | ||| Looks up the header of the given name.
 45 | |||
 46 | ||| `name` is converted to all upper-case letters before
 47 | ||| searching in the dictionary of headers. Use `lookupUpperCaseHeader`
 48 | ||| if `name` is already in upper-case letters.
 49 | export %inline
 50 | lookupHeader : (name : String) -> Headers -> Maybe ByteString
 51 | lookupHeader = lookupUpperCaseHeader . toUpper
 52 |
 53 | --------------------------------------------------------------------------------
 54 | -- Specialized Utilities
 55 | --------------------------------------------------------------------------------
 56 |
 57 | public export
 58 | Accept : String
 59 | Accept = "ACCEPT"
 60 |
 61 | public export
 62 | Authorization : String
 63 | Authorization = "AUTHORIZATION"
 64 |
 65 | public export
 66 | Content_Length : String
 67 | Content_Length = "CONTENT-LENGTH"
 68 |
 69 | public export
 70 | Content_Type : String
 71 | Content_Type = "CONTENT-TYPE"
 72 |
 73 | public export
 74 | Content_Disposition : String
 75 | Content_Disposition = "CONTENT-DISPOSITION"
 76 |
 77 | headerMay : {st : _} -> {x : _} -> String -> HRes st x t -> Headers -> Maybe t
 78 | headerMay nm res hs =
 79 |   lookupUpperCaseHeader nm hs >>= \bs => headerMay res bs
 80 |
 81 | headerVal : {st : _} -> {x : _} -> String -> HRes st x t -> t -> Headers -> t
 82 | headerVal nm res v hs =
 83 |   fromMaybe v $ lookupUpperCaseHeader nm hs >>= \bs => headerMay res bs
 84 |
 85 | ||| Reads the `Accept` header and converts it to a list of media types.
 86 | export %inline
 87 | accept : Headers -> MediaRanges
 88 | accept = headerVal Accept RAcc []
 89 |
 90 | ||| Checks if the given media type can be handled according to
 91 | ||| the given request headers.
 92 | export
 93 | acceptsMedia : Headers -> MediaType -> Bool
 94 | acceptsMedia hs mt = any (flip accepts mt . type) (accept hs)
 95 |
 96 | ||| Reads the `Content-Disposition` header and converts it to a media type.
 97 | export %inline
 98 | contentDisposition : Headers -> Maybe ContentDisp
 99 | contentDisposition = headerMay Content_Disposition RConD
100 |
101 | ||| Reads the `Content-Type` header and converts it to a media type.
102 | export %inline
103 | contentType : Headers -> Maybe ContentType
104 | contentType = headerMay Content_Type RConT
105 |
106 | ||| Checks if the given media type corresponds to the media type
107 | ||| of the request's content.
108 | export
109 | hasContentType : Headers -> MediaType -> Bool
110 | hasContentType hs t = Just t == map type (contentType hs)
111 |
112 | ||| Reads the `Content-Length` header and converts it to a natural number
113 | export
114 | contentLength : Headers -> Nat
115 | contentLength = headerVal Content_Length RConL 0
116 |
117 | export %inline
118 | parseHeaders : Origin -> ByteString -> Either (ParseError Void) Headers
119 | parseHeaders o = map MkHeaders . parseBytes (header RMap) o
120 |
121 | export %inline
122 | parseHeadersMay : ByteString -> Maybe Headers
123 | parseHeadersMay = map MkHeaders . headerMay RMap
124 |
125 | --------------------------------------------------------------------------------
126 | -- Test Parsing
127 | --------------------------------------------------------------------------------
128 |
129 | export
130 | testParseHeaders : ByteString -> IO ()
131 | testParseHeaders =
132 |   either (putStrLn . interpolate) printPairs . parseHeaders Virtual
133 |
134 |   where
135 |     printPairs : Headers -> IO ()
136 |     printPairs hs = for_ (kvList hs) $ \(n,v) => putStrLn "\{n}: \{v}"
137 |