0 | module HTTP.Response
 1 |
 2 | import HTTP.API
 3 | import HTTP.I18n
 4 | import JSON.Simple
 5 |
 6 | %default total
 7 |
 8 | --------------------------------------------------------------------------------
 9 | --          Response
10 | --------------------------------------------------------------------------------
11 |
12 | ||| HTTP Response
13 | |||
14 | ||| Currently, we include the content / body as a whole. This might
15 | ||| be changed to a stream of data if we ever decide to stream
16 | ||| large amounts of content.
17 | public export
18 | record Response where
19 |   constructor RP
20 |   headers : Headers
21 |   content : List ByteString
22 |
23 | export
24 | empty : Response
25 | empty = RP emptyHeaders []
26 |
27 | export
28 | addHeader :  String -> ByteString  -> Response -> Response
29 | addHeader x y = {headers $= insertHeader x y}
30 |
31 | export
32 | setStatus : Status -> Response -> Response
33 | setStatus s = addHeader "Status" (cast s)
34 |
35 | crlf : ByteString
36 | crlf = "\r\n"
37 |
38 | export
39 | responseBytes : Response -> List ByteString
40 | responseBytes (RP hs bs) =
41 |   case kvList hs of
42 |     [] => crlf :: crlf :: bs
43 |     ps => (ps >>= \(h,v) => [fromString h,":",v,crlf]) ++ crlf :: bs
44 |
45 | export
46 | setContentType : EncodeVia f t -> Response -> Response
47 | setContentType e = addHeader Content_Type (encodeMediaType $ mediaType @{e})
48 |
49 | export
50 | encodeBody :
51 |      Status
52 |   -> t
53 |   -> Headers
54 |   -> All (EncodeVia t) ts
55 |   -> Response
56 |   -> Response
57 | encodeBody s v hs []        rs = setStatus s rs
58 | encodeBody s v hs (e :: es) rs =
59 |   case acceptsMedia hs (mediaType @{e}) of
60 |     False => encodeBody s v hs es rs
61 |     True  => {content := encodeVia v e} rs |> setContentType e |> setStatus s
62 |
63 | --------------------------------------------------------------------------------
64 | --          Common Responses
65 | --------------------------------------------------------------------------------
66 |
67 | parameters {auto loc : HTTPLocal}
68 |   encErr : All (EncodeVia RequestErr) [JSON, Text]
69 |   encErr = %search
70 |
71 |   export
72 |   fromError : Maybe URI -> Headers -> RequestErr -> Response
73 |   fromError mu hs re@(RE st err _ _ _) =
74 |    let u := maybe "" interpolate mu
75 |     in encodeBody (MkStatus st err) ({path := u} re) hs encErr empty
76 |
77 |   export
78 |   fromStatus : URI -> Headers -> Status -> Response
79 |   fromStatus u hs = fromError (Just u) hs . requestErr
80 |
81 |   export
82 |   notFound : URI -> Headers -> Response
83 |   notFound u hs = fromStatus u hs notFound404
84 |
85 |   export
86 |   forbidden : URI -> Headers -> Response
87 |   forbidden u hs = fromStatus u hs forbidden403
88 |