blob: ef6ecfbf1c52406c3285ee3954ed8ff7905387eb (
plain)
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
|
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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 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 RandomSalt
deriving (Show)
data ProofOfWorkRequirement = ProofOfWorkRequirement
{ leadingZeros :: Int
, addedArgon2Iterations :: Word32
, randomSalt :: RandomSalt
}
deriving (Generic, Show)
-- | Using Text and not ByteString so that ProofOfWorkRequirement can have a
-- JSON instance.
newtype RandomSalt = RandomSalt { fromRandomSalt :: T.Text }
deriving (Generic, Show, Eq)
instance Hashable RandomSalt where
hashIO32 = hashIO32 . encodeUtf8 . fromRandomSalt
hashIO64 = hashIO64 . encodeUtf8 . fromRandomSalt
-- | 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 (RandomSalt -> ProofOfWorkRequirement)
mkProofOfWorkRequirement (Seconds n)
| lz < 1 = Nothing
| otherwise = Just $ ProofOfWorkRequirement lz its
where
lz = floor (logBase 2 (max 1 (fromIntegral n / fromIntegral s)) :: Double)
UseArgon2 (CPUCost (Seconds s) _) _ = proofOfWorkHashTunable its
its = 0
mkRandomSalt :: IO RandomSalt
mkRandomSalt = do
prg <- Raaz.newPRG () :: IO Raaz.SystemPRG
rs <- replicateM 16 (Raaz.random prg :: IO Word8)
return $ RandomSalt $ T.pack $ concatMap show rs
instance Raaz.Random Word8
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
isValidProofOfWork :: POWIdent p => ProofOfWork -> ProofOfWorkRequirement -> p -> Bool
isValidProofOfWork (ProofOfWork pow rsalt) req p =
samesalts && enoughzeros
where
samesalts = rsalt == randomSalt req
enoughzeros = all (== False) (take (leadingZeros req) (setBits b))
tunable = proofOfWorkHashTunable (addedArgon2Iterations req)
salt = Salt $ POWSalt $
encodeUtf8 (fromRandomSalt (randomSalt 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 (randomSalt req)
|
