Cryptographic signing of HTTP requests

[[ 🗃 ^v3e8r http-client-signature ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/v3e8r

SSH: darcs clone USERNAME@vervis.peers.community:v3e8r

Tags

TODO

src / Network / HTTP / Client /

Signature.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

{- This file is part of http-client-signature.
 -
 - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE TupleSections #-}

module Network.HTTP.Client.Signature
    ( signRequest
    , signRequestInto
    , signRequestBytes
    )
where

import Data.ByteString (ByteString)
import Data.Foldable (find)
import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock
import Network.HTTP.Client
import Network.HTTP.Date (utcToHTTPDate, formatHTTPDate)
import Network.HTTP.Types.Header (HeaderName, hDate, hHost, RequestHeaders)

import qualified Data.ByteString.Char8 as BC (pack)
import qualified Data.CaseInsensitive as CI (mk)
import qualified Network.HTTP.Signature as S

-- | Sign the given HTTP request and add the signature in a _Signature_ header.
--
-- If the list of header names includes _Date_ but such a header isn't found in
-- the request, add it before signing. Generate it from the given
-- @Maybe UTCTime@, using 'getCurrentTime' if 'Nothing' is given.
--
-- If the list of header names include _Host_ but such a header isn't found in
-- the request, add it before signing. Generate it from the 'host' and 'port'
-- of the request.
--
-- Throw 'HttpSigGenError' on error.
signRequest
    :: NonEmpty HeaderName
    -> Maybe S.Algorithm
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> UTCTime
    -> Request
    -> Either S.HttpSigGenError Request
signRequest = signRequestInto S.hSignature

-- | Like 'signRequest', but with an additional first parameter that specifies
-- into which HTTP header to place the signature (in 'signRequest', the
-- _Signature_ header is used).
signRequestInto
    :: HeaderName
    -> NonEmpty HeaderName
    -> Maybe S.Algorithm
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> UTCTime
    -> Request
    -> Either S.HttpSigGenError Request
signRequestInto hSig names malgo keyid sign now request = do
    (b, headers) <- signRequestBytes' names malgo keyid sign now request
    let hs = (hSig, b) : headers
    return $ request { requestHeaders = hs }

-- | Like 'signRequest', but returns the formatted header value as a
-- 'ByteString'.
signRequestBytes
    :: NonEmpty HeaderName
    -> Maybe S.Algorithm
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> UTCTime
    -> Request
    -> Either S.HttpSigGenError ByteString
signRequestBytes names malgo keyid sign now request =
    fst <$> signRequestBytes' names malgo keyid sign now request

signRequestBytes'
    :: NonEmpty HeaderName
    -> Maybe S.Algorithm
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> UTCTime
    -> Request
    -> Either S.HttpSigGenError (ByteString, RequestHeaders)
signRequestBytes' names malgo keyid sign now request =
    let headers = ensureDate names $ requestHeaders $ ensureHost names request
        sr = S.Request
            { S.requestMethod  = CI.mk $ method request
            , S.requestPath    = path request <> queryString request
            , S.requestHeaders = headers
            }
    in  (,headers) <$> S.signRequest names malgo keyid sign sr
    where
    ensureHost names' request' = request'
        { requestHeaders =
            if hHost `elem` names'
                then case find ((== hHost) . fst) headers of
                    Just _  -> headers
                    Nothing -> (hHost, mkHost request') : headers
                else headers
        }
        where
        headers = requestHeaders request'
        mkHost req =
            case (p, secure req) of
                (80 , False) -> h
                (443, True)  -> h
                _            -> h <> BC.pack (':' : show p)
            where
            p = port req
            h = host req
    ensureDate names' headers =
        if hDate `elem` names'
            then case find ((== hDate) . fst) headers of
                Just _  -> headers
                Nothing -> (hDate, formatHTTPDate $ utcToHTTPDate now) : headers
            else headers
[See repo JSON]