blob: 04aec57ded94e33ca91b3ac779defdde0195a47d (
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
|
{- 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
isValidProofOfWork :: ProofOfWork -> ProofOfWorkRequirement -> StorableObjectIdent -> Bool
isValidProofOfWork (ProofOfWork pow rsalt) req (StorableObjectIdent n) =
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 n
-- 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 :: ProofOfWorkRequirement -> StorableObjectIdent -> ProofOfWork
genProofOfWork req i = go allByteStrings
where
go [] = error "failed to generate Proof Of Work. This should be impossible!"
go (b:bs)
| isValidProofOfWork candidate req i = candidate
| otherwise = go bs
where
candidate = ProofOfWork b (randomSalt req)
|
