/
CryptoConditions.hs
132 lines (104 loc) · 4.52 KB
/
CryptoConditions.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
129
130
131
132
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- Crypto Conditions Standard API
--
-- The Condition type defined in this module supports the standard
-- condition types, library authors wishing to extend CryptoConditions
-- should copy and paste this file into their own project and define their own
-- Condition type.
--------------------------------------------------------------------------------
module Network.CryptoConditions
( module CCI
, Condition(..)
, ed25519Condition
, preimageCondition
, fulfillEd25519
) where
import qualified Crypto.PubKey.Ed25519 as Ed2
import Data.Aeson.Types
import Data.ByteString as BS
import Data.Monoid
import Data.Word
import qualified Data.Set as Set
import Network.CryptoConditions.Impl as CCI
import Network.CryptoConditions.Json as CCJ
data Condition =
Preimage Preimage
| Prefix Prefix Int Condition
| Threshold Word16 [Condition]
-- Rsa
| Ed25519 Ed2.PublicKey (Maybe Ed2.Signature)
| Anon Int Fingerprint Int (Set.Set ConditionType)
deriving (Show, Eq)
instance IsCondition Condition where
getType (Anon 0 _ _ _) = preimageType
getType (Anon 1 _ _ _) = prefixType
getType (Anon 2 _ _ _) = thresholdType
getType (Anon 4 _ _ _) = ed25519Type
getType (Anon n _ _ cts) = CT n "UNKNOWN" (cts == mempty) ""
getType (Threshold _ _) = thresholdType
getType (Ed25519 _ _) = ed25519Type
getType (Preimage _) = preimageType
getType (Prefix _ _ _) = prefixType
getCost (Threshold t subs) = thresholdCost t subs
getCost (Ed25519 _ _) = ed25519Cost
getCost (Preimage pre) = preimageCost pre
getCost (Prefix pre mml c) = prefixCost pre mml c
getCost (Anon _ _ c _) = c
getFingerprint (Threshold t subs) = thresholdFingerprint t subs
getFingerprint (Ed25519 pk _) = ed25519Fingerprint pk
getFingerprint (Preimage pre) = preimageFingerprint pre
getFingerprint (Prefix pre mml c) = prefixFingerprint pre mml c
getFingerprint (Anon _ fp _ _) = fp
getFulfillmentASN (Threshold t subs) = thresholdFulfillmentASN t subs
getFulfillmentASN (Ed25519 pk msig) = ed25519FulfillmentASN pk <$> msig
getFulfillmentASN (Preimage pre) = Just $ preimageFulfillmentASN pre
getFulfillmentASN (Prefix pre mml c) = prefixFulfillmentASN pre mml c
getFulfillmentASN (Anon _ _ _ _) = Nothing
getSubtypes (Threshold _ sts) = thresholdSubtypes sts
getSubtypes (Anon _ _ _ sts) = sts
getSubtypes (Prefix _ _ c) = prefixSubtypes c
getSubtypes _ = mempty
parseFulfillment 0 = parsePreimage Preimage
parseFulfillment 1 = parsePrefix Prefix
parseFulfillment 2 = parseThreshold Threshold
parseFulfillment 4 = parseEd25519 (\a b -> Ed25519 a (Just b))
parseFulfillment n = fail ("unknown condition type: " ++ show n)
verifyMessage (Preimage image) = verifyPreimage image
verifyMessage (Prefix pre mml cond) = verifyPrefix pre mml cond
verifyMessage (Threshold m subs) = verifyThreshold m subs
verifyMessage (Ed25519 pk (Just sig)) = verifyEd25519 pk sig
verifyMessage _ = const False
anon t f c = Anon t f c . toConditionTypes
toConditionTypes :: Set.Set Int -> Set.Set ConditionType
toConditionTypes = Set.map $
let u = undefined in (\tid -> getType $ Anon tid u u u)
preimageCondition :: BS.ByteString -> Condition
preimageCondition = Preimage
ed25519Condition :: Ed2.PublicKey -> Condition
ed25519Condition pk = Ed25519 pk Nothing
fulfillEd25519 :: Ed2.PublicKey -> Ed2.SecretKey
-> Message -> Condition -> Condition
fulfillEd25519 pk sk msg c@(Ed25519 pk' _) =
if pk == pk' then Ed25519 pk (Just $ Ed2.sign sk pk msg) else c
fulfillEd25519 pk sk msg (Threshold t subs) =
Threshold t $ fulfillEd25519 pk sk msg <$> subs
fulfillEd25519 pk sk msg (Prefix pre mml sub) =
Prefix pre mml $ fulfillEd25519 pk sk (pre <> msg) sub
fulfillEd25519 _ _ _ c = c
instance ToJSON Condition where
toJSON (Threshold t subs) = toJsonThreshold t subs
toJSON (Ed25519 pk msig) = toJsonEd25519 pk msig
toJSON (Prefix pre mml c) = toJsonPrefix pre mml c
toJSON (Preimage img) = toJsonPreimage img
toJSON c@(Anon _ _ _ _) = toJsonAnon c
instance FromJSON Condition where
parseJSON = withObject "condition" $ \o -> do
name <- o .: "type"
let method = case name of
"preimage-sha-256" -> CCJ.parseJsonPreimage Preimage
"prefix-sha-256" -> parseJsonPrefix Prefix
"threshold-sha-256" -> parseJsonThreshold Threshold
"ed25519-sha-256" -> parseJsonEd25519 Ed25519
_ -> fail ("Unknown Crypto-Condition type: " ++ name)
method o