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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HTTP.ProofOfWork where
import Types
import Types.Cost
import ExpensiveHash
import Tunables
import ByteStrings
import GHC.Generics
import qualified Data.Text as T
import qualified Data.ByteString as B
import Data.Text.Encoding (encodeUtf8)
import Raaz.Core.Encode
import qualified Raaz
import Data.BloomFilter.Hash
import Control.Monad
import Control.DeepSeq
import Data.Word
import Data.Bits
import Data.Monoid
import Prelude
-- | A value that the client has to do some work to calculate.
data ProofOfWork = ProofOfWork B.ByteString RequestID
deriving (Show, Generic)
instance NFData ProofOfWork
data ProofOfWorkRequirement = ProofOfWorkRequirement
{ leadingZeros :: Int
, addedArgon2Iterations :: Word32
, requestID :: RequestID
}
deriving (Generic, Show)
-- | A request ID has two parts, a RandomSalt and a HMAC.
-- The server can verify if a request ID is one it generated.
data RequestID = RequestID
{ randomSalt :: RandomSalt
, requestHMAC :: T.Text
}
deriving (Generic, Show, Eq)
instance NFData RequestID
instance Hashable RequestID where
hashIO32 = hashIO32 . hashRequestID
hashIO64 = hashIO64 . hashRequestID
hashRequestID :: RequestID -> B.ByteString
hashRequestID rid = encodeUtf8 (fromRandomSalt (randomSalt rid))
<> ":" <> encodeUtf8 (requestHMAC rid)
-- | Using Text and not ByteString so that ProofOfWorkRequirement can have a
-- JSON instance.
newtype RandomSalt = RandomSalt { fromRandomSalt :: T.Text }
deriving (Generic, Show, Eq)
instance NFData RandomSalt
-- | Servers should never demand a proof of work that takes longer than
-- this to generate. Note that if a server changes its mind and doubles
-- the proof of work, a client counts that cumulatively. So, a server
-- should avoid any single proof of work requirement taking more than half
-- this long.
maxProofOfWork :: Seconds
maxProofOfWork = Seconds (16*60)
-- | How long it will take to generate a proof of work meeting the
-- requirement, maximum.
--
-- Of course, a client can get lucky and find a value that works
-- on the very first try. On average, the client will need to work for half
-- as long as the returned number of Seconds.
generationTime :: ProofOfWorkRequirement -> Seconds
generationTime req =
let UseArgon2 (CPUCost (Seconds s) _) _ = proofOfWorkHashTunable (addedArgon2Iterations req)
in Seconds ((2^(leadingZeros req)) * s)
mkProofOfWorkRequirement :: Seconds -> Maybe (RequestID -> ProofOfWorkRequirement)
mkProofOfWorkRequirement (Seconds n)
| lz < 1 || n <= 1 = Nothing
| otherwise = Just $ ProofOfWorkRequirement lz its
where
lz = floor (logBase 2 (fromRational (max 1 (n / s))) :: Double)
UseArgon2 (CPUCost (Seconds s) _) _ = proofOfWorkHashTunable its
its = 0
newtype RequestIDSecret = RequestIDSecret (Raaz.Key (Raaz.HMAC Raaz.SHA256))
-- | Random data is generated insecurely, eg not locked in memory because
-- this is a transient secret.
newRequestIDSecret :: IO RequestIDSecret
newRequestIDSecret = RequestIDSecret <$> Raaz.insecurely gen
where
gen :: Raaz.RandM (Raaz.Key (Raaz.HMAC Raaz.SHA256))
gen = Raaz.random
mkRequestID :: RequestIDSecret -> IO RequestID
mkRequestID secret = mkRequeestID' secret <$> mkRandomSalt
mkRequeestID' :: RequestIDSecret -> RandomSalt -> RequestID
mkRequeestID' (RequestIDSecret key) salt =
let hmac = Raaz.hmacSha256 key (encodeUtf8 $ fromRandomSalt salt)
in RequestID salt (T.pack (showBase16 hmac))
validRequestID :: RequestIDSecret -> RequestID -> Bool
validRequestID secret rid =
let rid' = mkRequeestID' secret (randomSalt rid)
in requestHMAC rid == requestHMAC rid'
-- | Random data is generated insecurely, eg not locked in memory because
-- this is a transient secret.
mkRandomSalt :: IO RandomSalt
mkRandomSalt = do
rs <- Raaz.insecurely $ replicateM 16 gen
return $ RandomSalt $ T.pack $ concatMap show rs
where
gen :: Raaz.RandM Word8
gen = Raaz.random
class POWIdent p where
getPOWIdent :: p -> B.ByteString
instance POWIdent StorableObjectIdent where
getPOWIdent (StorableObjectIdent i) = i
data NoPOWIdent = NoPOWIdent
instance POWIdent NoPOWIdent where
getPOWIdent NoPOWIdent = B.empty
instance POWIdent Int where
getPOWIdent = encodeUtf8 . T.pack . show
-- Note that this does not check validRequestID.
isValidProofOfWork :: POWIdent p => ProofOfWork -> ProofOfWorkRequirement -> p -> Bool
isValidProofOfWork (ProofOfWork pow rid) req p = samerequestids && enoughzeros
where
samerequestids = rid == requestID req
enoughzeros = all (== False) (take (leadingZeros req) (setBits b))
tunable = proofOfWorkHashTunable (addedArgon2Iterations req)
salt = Salt $ POWSalt $
encodeUtf8 (fromRandomSalt (randomSalt (requestID req))) <> pow
ExpensiveHash _ hash = expensiveHash tunable salt (getPOWIdent p)
-- Since expensiveHash generates an ascii encoded hash that
-- includes the parameters, take the sha256 of it to get the
-- bytestring that is what's checked for the neccesary number
-- of leading 0 bits.
b = Raaz.toByteString $ Raaz.sha256 $ encodeUtf8 hash
setBits :: B.ByteString -> [Bool]
setBits = concatMap go . B.unpack
where
go byte = map (uncurry testBit) (zip (repeat byte) [0..7])
newtype POWSalt = POWSalt B.ByteString
instance Encodable POWSalt where
toByteString (POWSalt n) = n
fromByteString = Just . POWSalt
genProofOfWork :: POWIdent p => ProofOfWorkRequirement -> p -> ProofOfWork
genProofOfWork req p = go allByteStrings
where
go [] = error "failed to generate Proof Of Work. This should be impossible!"
go (b:bs)
| isValidProofOfWork candidate req p = candidate
| otherwise = go bs
where
candidate = ProofOfWork b (requestID req)
|
