/
Assertion.hs
152 lines (133 loc) · 5.93 KB
/
Assertion.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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
module Assertion where
import Control.Monad (void, guard)
import Control.Error (readMay, hush)
import Data.Maybe (mapMaybe, listToMaybe)
import Data.List ((\\))
import Data.Base58Address (RippleAddress)
import Control.Applicative ((*>))
import Data.Attoparsec.Text (Parser, parseOnly, decimal, string, takeTill, space, endOfLine, endOfInput)
import Data.Attoparsec.Combinator (choice)
import Data.Char (isSpace)
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LZ
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.OpenPGP as OpenPGP
import qualified Data.OpenPGP.CryptoAPI as OpenPGP
-- | Assertions users can make about each other
data AssertionType = MadePayment | MissedPayment | NotTrusted | Chargeback
deriving (Eq)
instance Show AssertionType where
show MadePayment = "made a payment"
show MissedPayment = "missed a payment"
show NotTrusted = "not trusted"
show Chargeback = "chargeback"
instance Read AssertionType where
readsPrec _ s = case parseOnly assertionTypeParser (T.pack s) of
Left _ -> []
Right x -> [(x, "")]
type Assertion = (AssertionType, RippleAddress, UTCTime)
-- | Do OpenPGP verification and extract an assertion from a message
verifyAssertion :: UTCTime -> OpenPGP.Message -> OpenPGP.Message -> Maybe (OpenPGP.Packet, Assertion)
verifyAssertion time (OpenPGP.Message keys) msg = listToMaybe $
mapMaybe (assertionFromVerifiedSig validKeys) verifiedSigs
where
verifiedSigs = map (OpenPGP.verify validKeys) (OpenPGP.signatures msg)
validKeys = OpenPGP.Message $ map fst $
filter (maybe True (\e -> e `diffUTCTime` time > 0) . snd)
(keyExpirations unRevoked)
unRevoked = OpenPGP.Message (keys \\ revoked)
revoked = map fst (keyRevocations (OpenPGP.Message keys))
-- Given a particular verified signature, extract the assertion
assertionFromVerifiedSig :: OpenPGP.Message -> OpenPGP.SignatureOver -> Maybe (OpenPGP.Packet, Assertion)
assertionFromVerifiedSig keys (OpenPGP.DataSignature (OpenPGP.LiteralDataPacket {
OpenPGP.content = bytes
}) [sig]) = do
guard (signatureExpiry sig == Nothing) -- Reject expiring signatures
key <- issuerKey keys sig
text <- hush $ T.decodeUtf8' $ BS.concat $ LZ.toChunks $ bytes
assertion <- hush (parseOnly assertionParser text)
return (key, assertion)
assertionFromVerifiedSig _ _ = Nothing
-- | Helper to get the key that made a particular signature
issuerKey :: OpenPGP.Message -> OpenPGP.Packet -> Maybe OpenPGP.Packet
issuerKey keys sig = do
issuer <- OpenPGP.signature_issuer sig
OpenPGP.find_key OpenPGP.fingerprint keys issuer
-- | unhashed expiry is the same as no expiry
-- If no creation time, also get a Nothing
-- Return value is since POSIX epoch
signatureExpiry :: OpenPGP.Packet -> Maybe Integer
signatureExpiry p | OpenPGP.isSignaturePacket p = do
let pkts = OpenPGP.hashed_subpackets p
creationTime <- listToMaybe (mapMaybe creationTimeSubpacket pkts)
expiryAfter <- listToMaybe (mapMaybe expirySubpacket pkts)
return $! (creationTime + expiryAfter)
signatureExpiry _ = Nothing
creationTimeSubpacket :: OpenPGP.SignatureSubpacket -> Maybe Integer
creationTimeSubpacket (OpenPGP.SignatureCreationTimePacket secs) =
Just $ fromIntegral secs
creationTimeSubpacket _ = Nothing
expirySubpacket :: OpenPGP.SignatureSubpacket -> Maybe Integer
expirySubpacket (OpenPGP.SignatureExpirationTimePacket secs) =
Just $ fromIntegral secs
expirySubpacket _ = Nothing
keyExpirySubpacket :: OpenPGP.SignatureSubpacket -> Maybe Integer
keyExpirySubpacket (OpenPGP.KeyExpirationTimePacket secs) =
Just $ fromIntegral secs
keyExpirySubpacket _ = Nothing
keyExpirations :: OpenPGP.Message -> [(OpenPGP.Packet, Maybe UTCTime)]
keyExpirations = mapMaybe keyExpirationSignature . OpenPGP.signatures
-- | Assumes key packet
keyAndExpiryToTime :: (Integral a) => OpenPGP.Packet -> a -> UTCTime
keyAndExpiryToTime k expiry =
posixSecondsToUTCTime $ (realToFrac $ OpenPGP.timestamp k) + (realToFrac expiry)
keyExpirationSignature :: OpenPGP.SignatureOver -> Maybe (OpenPGP.Packet, Maybe UTCTime)
keyExpirationSignature (OpenPGP.DataSignature {}) = Nothing
keyExpirationSignature s
| null subpackets = Nothing -- No valid self-signature
| otherwise = Just $ maybe (k, Nothing)
((,)k . Just . keyAndExpiryToTime k) $
listToMaybe $ mapMaybe keyExpirySubpacket subpackets
where
subpackets = concatMap OpenPGP.hashed_subpackets verifiedSelfSigs
verifiedSelfSigs = OpenPGP.signatures_over $
OpenPGP.verify (OpenPGP.Message [k]) s
k = case s of
OpenPGP.SubkeySignature {} -> OpenPGP.subkey s
_ -> OpenPGP.topkey s
keyRevocations :: OpenPGP.Message -> [(OpenPGP.Packet, OpenPGP.Packet)]
keyRevocations = concatMap keyRevocationSignature . OpenPGP.signatures
-- | Return is [(Key, Signature)]
keyRevocationSignature :: OpenPGP.SignatureOver -> [(OpenPGP.Packet, OpenPGP.Packet)]
keyRevocationSignature (OpenPGP.DataSignature {}) = []
keyRevocationSignature s = map ((,)k) verifiedRevocationSelfSigs
where
verifiedRevocationSelfSigs = filter ((==0x20) . OpenPGP.signature_type) $
OpenPGP.signatures_over $ OpenPGP.verify (OpenPGP.Message [k]) s
k = case s of
OpenPGP.SubkeySignature {} -> OpenPGP.subkey s
_ -> OpenPGP.topkey s
-- Parse our assertions from text
assertionParser :: Parser Assertion
assertionParser = do
time <- fmap (posixSecondsToUTCTime . realToFrac) decimal
void $ string (T.pack ": ")
adr <- fmap T.unpack $ takeTill isSpace
decodedAdr <- case readMay adr of
Just x -> return x
Nothing -> fail $ adr ++ " is not a valid Ripple address."
void space
assert <- assertionTypeParser
endOfLine
endOfInput
return $ (assert, decodedAdr, time)
assertionTypeParser :: Parser AssertionType
assertionTypeParser = choice [
string (T.pack "made a payment") *> return MadePayment,
string (T.pack "missed a payment") *> return MissedPayment,
string (T.pack "not trusted") *> return NotTrusted,
string (T.pack "chargeback") *> return Chargeback
]