Browse files

You can now submit assertions

  • Loading branch information...
1 parent b866753 commit 56eed70e131e73a2f2a71f2760315d566fa69678 @singpolyma committed Mar 23, 2013
Showing with 201 additions and 75 deletions.
  1. +1 −1 .gitignore
  2. +55 −5 Application.hs
  3. +3 −0 Assertion.hs
  4. +24 −0 Keyserver.hs
  5. +17 −4 Main.hs
  6. +5 −5 Makefile
  7. +10 −0 Records.hs
  8. +25 −46 Sqlite3.hs
  9. +1 −14 TODO
  10. +2 −0 routes
  11. +58 −0 view/submit.mustache
View
2 .gitignore
@@ -5,7 +5,7 @@
*.rej
Main
MustacheTemplates.hs
-PathPieces.hs
+PathHelpers.hs
Routes.hs
dev.db
tests/suite
View
60 Application.hs
@@ -1,25 +1,33 @@
+{-# LANGUAGE CPP #-}
module Application where
import Data.List (intercalate)
import Data.String (fromString)
import Data.Maybe (fromMaybe)
import Network.HTTP.Accept (selectAcceptType)
-import Network.Wai.Parse (parseRequestBody, parseHttpAccept)
+import Network.Wai.Parse (parseRequestBody, parseHttpAccept, getRequestBodyType, parseRequestBody, RequestBodyType(..), lbsBackEnd, fileContent)
import Network.Wai (Request(..), Response(..), Application)
import Network.HTTP.Types (ok200, notFound404, seeOther303, badRequest400, notAcceptable406, Status, ResponseHeaders)
-import Network.Wai.Util (string, stringHeaders, json)
+import Network.Wai.Util (string, stringHeaders, json, bodyBytestring, redirect')
import Web.PathPieces (PathPiece(..))
import Data.Base58Address (RippleAddress)
-import Control.Error (readMay)
+import Control.Error (readMay, headMay)
import Control.Monad.Trans (liftIO)
import Database.SQLite.Simple (query, field, FromRow(..), Connection, open, close)
import Database.SQLite.Simple.ToField (ToField(..))
+import Data.Binary (Binary, decodeOrFail)
+import Network.URI (URI(..))
+import Network.URI.Partial (relativeTo)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TL
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LZ
import Records
import MustacheTemplates
+import Sqlite3
+#include "PathHelpers.hs"
-- Orphan instances, do not import this module!
@@ -42,8 +50,8 @@ responseTextBuilder s h = ResponseBuilder s h . Blaze.fromLazyText . TL.toLazyTe
on404 :: Application
on404 _ = string notFound404 [] "Not Found"
-reportFor :: Connection -> RippleAddress -> Application
-reportFor db adr req = do
+reportFor :: URI -> Connection -> RippleAddress -> Application
+reportFor _ db adr req = do
assertions <- liftIO $ query db (fromString "SELECT `from`, `fromFingerprint`, `to`, `at`, `asserted`, `assertion` FROM assertions WHERE `to` = ?") [adr]
case acceptType of
"text/html" ->
@@ -57,3 +65,45 @@ reportFor db adr req = do
acceptType' = (selectAcceptType supportedTypes . parseHttpAccept) =<<
lookup (fromString "Accept") (requestHeaders req)
supportedTypes = ["text/html", "application/json"]
+
+assertFor :: URI -> Connection -> RippleAddress -> Application
+assertFor root db adr req = do
+ -- TODO: force adr to be the address of the object
+
+ body <- case getRequestBodyType req of
+ Just (Multipart _) -> fmap (fromMaybe LZ.empty . fmap (fileContent . snd) . headMay . snd) (parseRequestBody lbsBackEnd req)
+ _ -> fmap (LZ.fromChunks . (:[])) (bodyBytestring req)
+
+ result <- liftIO $ case decodeOrFail body of
+ Left _ -> return $ Left "Post data is not a valid OpenPGP message."
+ Right (_,_,x) -> insertVerifiedAssertion db x
+
+ case acceptType of
+ "text/html" ->
+ case result of
+ Left e -> string badRequest400 [] (e ++ "\n")
+ Right () -> redirect' seeOther303 [] (reportForPath adr `relativeTo` root)
+ "text/plain" ->
+ case result of
+ Left e -> string badRequest400 [] (e ++ "\n")
+ Right () -> string ok200 [] "success"
+ "application/json" ->
+ case result of
+ Left e -> json ok200 [] (Aeson.object [
+ (Aeson..=) (T.pack "error") (Aeson.toJSON e)
+ ])
+ Right () -> json ok200 [] (Aeson.object [
+ (Aeson..=) (T.pack "status") ("success")
+ ])
+ _ -> string notAcceptable406 [] (intercalate "\n" supportedTypes)
+ where
+ acceptType = fromMaybe (head supportedTypes) acceptType'
+ acceptType' = (selectAcceptType supportedTypes . parseHttpAccept) =<<
+ lookup (fromString "Accept") (requestHeaders req)
+ supportedTypes = ["text/html", "text/plain", "application/json"]
+
+submitFor :: URI -> Connection -> RippleAddress -> Application
+submitFor root _ adr req =
+ return $ responseTextBuilder ok200 headers (viewSubmit htmlEscape $ SubmitForm adr (assertForPath adr `relativeTo` root))
+ where
+ Just headers = stringHeaders [("Content-Type", "text/html; charset=utf8")]
View
3 Assertion.hs
@@ -18,6 +18,9 @@ import qualified Data.Text.Encoding as T
import qualified Data.OpenPGP as OpenPGP
import qualified Data.OpenPGP.CryptoAPI as OpenPGP
+import Debug.Trace
+traceAlong x = traceShow x x
+
-- | Assertions users can make about each other
data AssertionType = MadePayment | MissedPayment | NotTrusted | Chargeback
deriving (Eq)
View
24 Keyserver.hs
@@ -0,0 +1,24 @@
+module Keyserver where
+
+import Control.Error (hush, MaybeT(..), runMaybeT, hoistMaybe, headMay)
+import Data.Binary (decodeOrFail)
+import qualified Network.HTTP as HTTP
+import qualified Data.OpenPGP as OpenPGP
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as ASCIIArmor
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor.Types as ASCIIArmor
+import qualified Data.ByteString.Lazy as LZ
+
+fetchKey :: String -> IO (Maybe OpenPGP.Message)
+fetchKey fpr = runMaybeT $ do
+ r <- MaybeT $ fmap hush $ HTTP.simpleHTTP req
+ -- XXX: Data is all ASCII, but this is still a terrible hack
+ let rbytes = LZ.pack $ map (toEnum.fromEnum) (HTTP.rspBody r)
+ armor <- hoistMaybe $ headMay =<< hush (ASCIIArmor.decodeLazy rbytes :: Either String [ASCIIArmor.Armor])
+ bytes <- case armor of
+ ASCIIArmor.Armor ASCIIArmor.ArmorPublicKeyBlock _ bytes -> return bytes
+ _ -> hoistMaybe Nothing
+ case decodeOrFail bytes of
+ Left _ -> hoistMaybe Nothing
+ Right (_,_,x) -> return x
+ where
+ req = HTTP.getRequest $ "http://singpolyma.net:11371/pks/lookup?op=get&search=0x" ++ fpr ++ "&exact=on&options=mr"
View
21 Main.hs
@@ -1,6 +1,9 @@
module Main (main) where
import Control.Monad (void)
+import System.Environment (getArgs)
+import Network.URI (parseAbsoluteURI, URI(..))
+import Control.Error (err)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
@@ -14,8 +17,18 @@ import Network.Wai.Dispatch
import Routes
import Application
+addTrailingSlash :: URI -> URI
+addTrailingSlash u@(URI {uriPath = []}) = u {uriPath = "/"}
+addTrailingSlash u@(URI {uriPath = p})
+ | last p == '/' = u
+ | otherwise = u {uriPath = p ++ "/"}
+
main :: IO ()
-main = void $ withConnection "./dev.db"
- (\db -> run 3000 $
- logStdoutDev $ autohead $ acceptOverride $ jsonp $ -- Middleware
- dispatch on404 $ routes db) -- Do routing
+main = main' . map (fmap addTrailingSlash . parseAbsoluteURI) =<< getArgs
+ where
+ main' [Just root@(URI {uriAuthority = Just _})] =
+ void $ withConnection "./dev.db"
+ (\db -> run 3000 $
+ logStdoutDev $ autohead $ acceptOverride $ jsonp $ -- Middleware
+ dispatch on404 $ routes root db) -- Do routing
+ main' _ = err "Usage: ./Main <Root URI>"
View
10 Makefile
@@ -1,14 +1,14 @@
-Main: Main.hs Application.hs Routes.hs MustacheTemplates.hs
+Main: Main.hs Application.hs Routes.hs MustacheTemplates.hs PathHelpers.hs
ghc -Wall -fno-warn-name-shadowing Main.hs
Routes.hs: routes
- routeGenerator -r -m Application -n 1 $< > $@
+ routeGenerator -r -m Application -n 2 $< > $@
PathHelpers.hs: routes
- routeGenerator -p -n 1 $< > $@
+ routeGenerator -p -n 2 $< > $@
-MustacheTemplates.hs: Records.hs view/report.mustache
- mustache2hs -m Records.hs view/report.mustache Report > $@
+MustacheTemplates.hs: Records.hs view/report.mustache view/submit.mustache
+ mustache2hs -m Records.hs view/report.mustache Report view/submit.mustache SubmitForm > $@
clean:
find -name '*.o' -o -name '*.hi' | xargs $(RM)
View
10 Records.hs
@@ -11,6 +11,7 @@ import Data.Time.Clock (UTCTime)
import Data.Binary (Binary, decodeOrFail, encode)
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)
+import Network.URI (URI(..))
import qualified Data.ByteString.Lazy as LZ
import qualified Data.OpenPGP as OpenPGP
import qualified Data.OpenPGP.CryptoAPI as OpenPGP
@@ -26,9 +27,18 @@ instance TL.Buildable RippleAddress where
instance TL.Buildable AssertionType where
build = TL.build . TL.Shown
+instance TL.Buildable URI where
+ build = TL.build . TL.Shown
+
instance ToField RippleAddress where
toField adr = toField (show adr)
+data SubmitForm = SubmitForm {
+ formAddress :: RippleAddress,
+ formAction :: URI
+ }
+ deriving (Show, Eq)
+
data Report = Report {
address :: RippleAddress,
assertions :: [FormattedAssertionRow]
View
71 Sqlite3.hs
@@ -1,75 +1,54 @@
module Sqlite3 where
import Control.Applicative
+import Data.String (fromString)
import Control.Monad (when)
import Data.List (find)
import Control.Arrow (first)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.String (fromString)
-import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import Control.Error (readMay, hush, tryHead, noteT, EitherT(..), MaybeT(..), hoistMaybe, throwT)
+import Data.Time.Clock (getCurrentTime, diffUTCTime, addUTCTime)
+import Control.Error (readMay, hush, tryHead, noteT, EitherT(..), MaybeT(..), hoistMaybe, throwT, headMay)
import Data.Base58Address (RippleAddress)
-import Database.SQLite.Simple (query, field, FromRow(..), Connection, open, close)
+import Database.SQLite.Simple (query, field, FromRow(..), Connection, execute)
import Data.Binary (Binary, decodeOrFail)
import Control.Exception (try)
import Control.Monad.Trans (liftIO)
import qualified Data.OpenPGP as OpenPGP
+import qualified Data.OpenPGP.CryptoAPI as OpenPGP
import qualified Data.ByteString.Lazy as LZ
+import Keyserver
+import Records
import Assertion
-import Websocket hiding (readM)
-
-data AddressAndKey = AddressAndKey RippleAddress OpenPGP.Message
- deriving (Show, Eq)
-
-instance FromRow AddressAndKey where
- fromRow = AddressAndKey <$> (field >>= readM) <*> (field >>= decodeM)
-
-decodeM :: (Binary a, Monad m) => LZ.ByteString -> m a
-decodeM bytes = case decodeOrFail bytes of
- Left (_,_,e) -> fail e
- Right (_,_,x) -> return x
-
--- | Signal read errors in some Monad (for parsing)
-readM :: (Read r, Monad m) => String -> m r
-readM s = case readMay s of
- Just x -> return x
- Nothing -> fail $ s ++ " is invalid"
-
-findByKeyId :: Connection -> [String] -> IO [AddressAndKey]
-findByKeyId conn keyIds = query conn q (map ('%':) keyIds)
- where
- q = fromString $ "SELECT ripple_address, keydata FROM keys WHERE 1=0" ++
- concat (replicate (length keyIds) like)
- like = " OR fingerprint LIKE ?"
issuerKeyIds :: OpenPGP.Message -> [String]
issuerKeyIds (OpenPGP.Message ((OpenPGP.CompressedDataPacket _ (OpenPGP.Message p1)):p2)) =
issuerKeyIds (OpenPGP.Message (p1 ++ p2))
issuerKeyIds (OpenPGP.Message pkts) = mapMaybe OpenPGP.signature_issuer pkts
-processObject :: Connection -> OpenPGP.Message -> IO (Either String (RippleAddress, Assertion))
-processObject conn msg = runEitherT $ do
+extractVerifiedAssertion :: OpenPGP.Message -> IO (Either String (OpenPGP.Packet, OpenPGP.Message, Assertion))
+extractVerifiedAssertion msg = runEitherT $ do
time <- liftIO $ getCurrentTime
- r <- liftIO $ findByKeyId conn (issuerKeyIds msg)
- (adr, obj@(assertion, target, at)) <- tryHead "No valid signed object found." $
- mapMaybe (\(AddressAndKey adr k) ->
- fmap (first (const adr)) (verifyAssertion time k msg)
- ) r
+ k <- noteT "Keyserver fetch failed." $ (MaybeT . fetchKey) =<< (hoistMaybe $ headMay (issuerKeyIds msg))
+ (adr, obj@(assertion, target, at)) <- noteT "No valid signed object found." $ hoistMaybe $
+ verifyAssertion time k msg
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
- let line = filter ((== target) . lineAccount) lines
- when (null line) (throwT $ show adr ++ " has no credit relationship with " ++ show target)
- let isOwed = any ((>0). lineBalance) line
+ return (adr, k, obj)
+
+insertVerifiedAssertion :: Connection -> OpenPGP.Message -> IO (Either String ())
+insertVerifiedAssertion conn msg = runEitherT $ do
+ (key, keyM, (typ,to,time)) <- EitherT $ extractVerifiedAssertion msg
+ let fpr = OpenPGP.fingerprint key
+ let row = AssertionRow keyM fpr to time typ msg
- -- TODO: refuse objects from A to B too close together
+ -- refuse objects from this key that are too close together
+ r <- liftIO $ query conn (fromString "SELECT count(1) FROM assertions WHERE `at` > ? AND `at` < ?") (addUTCTime (-10) time, addUTCTime 10 time)
+ case r of
+ [[x]] | (x::Int) > 0 -> throwT "You have submitted other assertions too close in time to that assertion."
+ _ -> return ()
- case assertion of
- MadePayment -> return (adr, obj)
- Chargeback -> return (adr, obj)
- MissedPayment | isOwed -> return (adr, obj)
- NotTrusted | isOwed -> return (adr, obj)
- _ -> throwT (show target ++ " is not in debt to " ++ show adr)
+ liftIO $ execute conn (fromString "INSERT INTO assertions VALUES (?,?,?,?,?,?)") row
View
15 TODO
@@ -1,14 +1 @@
-thread A that just waits on websocket for messages
- If it's not a sort we understand, ignore it
-
-thread B that gets signaled by thread A on new message and also takes requests to be sent out
- If it's a transaction, are we waiting for this one to auth someone?
- If yes, then switch their status
- If it's a response we're waiting for, send it back
- Else, ignore it
-
-NEEDS TO BE A REC IN Records.hs YOU FOOL! AssertionRow probably also needs ToRow. We store normalized data from the blob in the DB for aggregation and sorting, and so might as well use it for display. INVESTIGATE HOW UTCTIME IS STORED IN DB!
-
-Need JSON outputs also, just derive ToJSON for the record I expect. Include blobs in the JSON?
-
-NO SEQUENTIAL IDS! data: URIs? Hashes?
+SIGNING SUBKEYS
View
2 routes
@@ -1 +1,3 @@
GET /for/: => reportFor
+GET /for/:/submit => submitFor
+POST /for/: => assertFor
View
58 view/submit.mustache
@@ -0,0 +1,58 @@
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <base href="http://rippleunion.com/" />
+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
+ <title>Submit Assertion for {{formAddress}}</title>
+
+ <style type="text/css">
+ html, body {
+ background-color: #abcdef;
+ font-family: "Liberation Sans", sans-serif;
+ }
+
+ body {
+ margin-left: 10%;
+ margin-right: 10%;
+ margin-top: 2em;
+ }
+
+ body > h1 {
+ overflow: hidden;
+ }
+
+ h1 * {
+ vertical-align: middle;
+ }
+
+ h1 img {
+ float: left;
+ padding-right: 5em;
+ }
+
+ .rippleAddress {
+ font-size: 0.5em;
+ }
+
+ a[rel=enclosure] img {
+ position: relative;
+ top: 4px;
+ }
+
+ input {
+ display: block;
+ }
+ </style>
+ </head>
+
+ <body>
+ <h1><img src="/logo.png" alt="Ripple Union" /> Submit Assertion for <span class="rippleAddress">{{formAddress}}</span></h1>
+
+ <form method="post" action="{{formAction}}" enctype="multipart/form-data">
+ <label for="assertion">OpenPGP signed assertion</label>
+ <input type="file" id="assertion" name="assertion" />
+ <input type="submit" value="Submit" />
+ </form>
+
+ </body>
+</html>

0 comments on commit 56eed70

Please sign in to comment.