You can now submit assertions

.gitignore

@@ -5,7 +5,7 @@
 *.rej
 Main
 MustacheTemplates.hs
-PathPieces.hs
+PathHelpers.hs
 Routes.hs
 dev.db
 tests/suite

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")]

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)

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"

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>"

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)

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]

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

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

routes

@@ -1 +1,3 @@
 GET /for/: => reportFor
+GET /for/:/submit => submitFor
+POST /for/: => assertFor

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>