Permalink
Browse files

Object -> Assertion, factor things out of sum type

  • Loading branch information...
1 parent 58bb518 commit aa1f37abbaad531012b8f38e742cdbcbd006fedd @singpolyma committed Mar 19, 2013
Showing with 32 additions and 44 deletions.
  1. +18 −30 VerifyObject.hs → Assertion.hs
  2. +14 −14 Sqlite3.hs
View
48 VerifyObject.hs → Assertion.hs
@@ -1,4 +1,4 @@
-module VerifyObject where
+module Assertion where
import Control.Monad (void, guard)
import Control.Error (readMay, hush)
@@ -19,27 +19,15 @@ import qualified Data.OpenPGP as OpenPGP
import qualified Data.OpenPGP.CryptoAPI as OpenPGP
-- | Assertions users can make about each other
-data Object =
- MadePayment UTCTime RippleAddress |
- MissedPayment UTCTime RippleAddress |
- NotTrusted UTCTime RippleAddress |
- Chargeback UTCTime RippleAddress
+data AssertionType = MadePayment | MissedPayment | NotTrusted | Chargeback
deriving (Eq, Show)
-objectAddress :: Object -> RippleAddress
-objectAddress (MadePayment _ adr) = adr
-objectAddress (MissedPayment _ adr) = adr
-objectAddress (NotTrusted _ adr) = adr
+type Assertion = (AssertionType, RippleAddress, UTCTime)
-objectTime :: Object -> UTCTime
-objectTime (MadePayment t _) = t
-objectTime (MissedPayment t _) = t
-objectTime (NotTrusted t _) = t
-
--- | Do OpenPGP verification and extract an object from a message
-verifyObject :: UTCTime -> OpenPGP.Message -> OpenPGP.Message -> Maybe (OpenPGP.Packet, Object)
-verifyObject time (OpenPGP.Message keys) msg = listToMaybe $
- mapMaybe (objectFromVerifiedSig validKeys) verifiedSigs
+-- | 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 $
@@ -48,17 +36,17 @@ verifyObject time (OpenPGP.Message keys) msg = listToMaybe $
unRevoked = OpenPGP.Message (keys \\ revoked)
revoked = map fst (keyRevocations (OpenPGP.Message keys))
--- Given a particular verified signature, extract the object
-objectFromVerifiedSig :: OpenPGP.Message -> OpenPGP.SignatureOver -> Maybe (OpenPGP.Packet, Object)
-objectFromVerifiedSig keys (OpenPGP.DataSignature (OpenPGP.LiteralDataPacket {
+-- 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
- object <- hush (parseOnly objectParser text)
- return (key, object)
-objectFromVerifiedSig _ _ = Nothing
+ 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
@@ -129,22 +117,22 @@ keyRevocationSignature s = map ((,)k) verifiedRevocationSelfSigs
OpenPGP.SubkeySignature {} -> OpenPGP.subkey s
_ -> OpenPGP.topkey s
--- Parse our objects from text
-objectParser :: Parser Object
-objectParser = do
+-- 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
- cons <- choice [
+ assert <- 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
]
endOfLine
endOfInput
- return $ cons time decodedAdr
+ return $ (assert, decodedAdr, time)
View
28 Sqlite3.hs
@@ -16,7 +16,7 @@ import Control.Monad.Trans (liftIO)
import qualified Data.OpenPGP as OpenPGP
import qualified Data.ByteString.Lazy as LZ
-import VerifyObject
+import Assertion
import Websocket hiding (readM)
data AddressAndKey = AddressAndKey RippleAddress OpenPGP.Message
@@ -51,28 +51,28 @@ issuerKeyIds (OpenPGP.Message pkts) = mapMaybe OpenPGP.signature_issuer pkts
tryFind :: (Monad m) => e -> (a -> Bool) -> [a] -> EitherT e m a
tryFind e p xs = noteT e $ hoistMaybe $ find p xs
-processObject :: Connection -> OpenPGP.Message -> IO (Either String (RippleAddress, Object))
+processObject :: Connection -> OpenPGP.Message -> IO (Either String (RippleAddress, Assertion))
processObject conn msg = runEitherT $ do
time <- liftIO $ getCurrentTime
r <- liftIO $ findByKeyId conn (issuerKeyIds msg)
- (adr,obj) <- tryHead "No valid signed object found." $
+ (adr, obj@(assertion, target, at)) <- tryHead "No valid signed object found." $
mapMaybe (\(AddressAndKey adr k) ->
- fmap (first (const adr)) (verifyObject time k msg)
+ fmap (first (const adr)) (verifyAssertion time k msg)
) r
- when (objectTime obj > time) (throwT "Signed object claims to be from the future.")
- when (time `diffUTCTime` objectTime obj > 3600) (throwT "Signed object is too old.")
+ when (at > time) (throwT "Signed object claims to be from the future.")
+ when (time `diffUTCTime` at > 3600) (throwT "Signed object is too old.")
AccountLinesR _ lines <- noteT (show adr ++ " has no credit relationships.") $ MaybeT $ doit adr
-- TODO: might have more than one credit relationship
- line <- tryFind (show adr ++ " has no credit relationship with " ++ show (objectAddress obj))
- ((== objectAddress obj) . lineAccount) lines
+ line <- tryFind (show adr ++ " has no credit relationship with " ++ show target)
+ ((== target) . lineAccount) lines
-- TODO: refuse objects from A to B too close together
- case obj of
- MadePayment _ _-> return (adr, obj)
- Chargeback _ _-> return (adr, obj)
- MissedPayment _ _ | lineBalance line > 0 -> return (adr, obj)
- NotTrusted _ _ | lineBalance line > 0 -> return (adr, obj)
- _ -> throwT (show (objectAddress obj) ++ " is not in debt to " ++ show adr)
+ case assertion of
+ MadePayment -> return (adr, obj)
+ Chargeback -> return (adr, obj)
+ MissedPayment | lineBalance line > 0 -> return (adr, obj)
+ NotTrusted | lineBalance line > 0 -> return (adr, obj)
+ _ -> throwT (show target ++ " is not in debt to " ++ show adr)

0 comments on commit aa1f37a

Please sign in to comment.