Switch to quote API

Application.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-module Application (federationEndpoint) where
+module Application (federationEndpoint, quoteEndpoint) where
 
 import Prelude ()
 import BasicPrelude
@@ -9,21 +9,25 @@ import Data.Base58Address (RippleAddress)
 import Database.SQLite3 (SQLError(..), Error(ErrorConstraint))
 import qualified Data.Text as T
 
-import Network.Wai (Application, queryString)
+import Network.Wai (Application, Response, queryString)
 import Network.HTTP.Types (ok200, badRequest400, notFound404)
 import Network.Wai.Util (stringHeaders, json, queryLookup)
 
 import qualified Vogogo as Vgg
 import qualified Vogogo.Customer as VggC
 
 import Network.URI (URI(..), URIAuth(..))
+import Network.URI.Partial (relativeTo)
 
 import Database.SQLite.Simple (query, execute, Connection, Query)
 import Database.SQLite.Simple.ToRow (ToRow)
 
 import Records
 #include "PathHelpers.hs"
 
+fee :: Double
+fee = 5
+
 type Action a = URI -> Connection -> Vgg.Auth -> RippleAddress -> a
 Just [cors] = stringHeaders [("Access-Control-Allow-Origin", "*")]
 
@@ -39,12 +43,45 @@ parseAccountNumbers t
 	where
 	pieces@(_:i:_) = T.splitOn (s"-") t
 
+
+err :: (Monad m) => FederationError -> m Response
+err e@(FederationError NoSuchUser _) = json notFound404 [cors] e
+err e = json badRequest400 [cors] e
+
+nodomain :: FederationError
+nodomain = FederationError NoSuchDomain "That domain is not served here."
+
+invalidAccount :: FederationError
+invalidAccount = FederationError NoSuchUser "Invalid account numbers."
+
+invalidCurrency :: FederationError
+invalidCurrency = FederationError InvalidParams "Invalid currency"
+
 federationEndpoint :: Action Application
-federationEndpoint root db vgg rAddr req = eitherT err return $ do
+federationEndpoint root _ _ _ req = eitherT err return $ do
+	(domain,account) <- (,) <$> fromQ "domain" <*> fromQ "destination"
+	when (domain /= rootDomain) $ throwT nodomain
+
+	(_,_,_) <- noteT' invalidAccount $ parseAccountNumbers account
+
+	json ok200 [cors] (ShouldQuote account domain (quoteEndpointPath `relativeTo` root))
+	where
+	Just rootDomain = T.pack . uriRegName <$> uriAuthority root
+	fromQ k = noteT' (FederationError InvalidParams ("No "++k++" provided.")) $
+		queryLookup k (queryString req)
+
+
+quoteEndpoint :: Action Application
+quoteEndpoint root db vgg rAddr req = eitherT err return $ do
 	(domain,account) <- (,) <$> fromQ "domain" <*> fromQ "destination"
 	when (domain /= rootDomain) $ throwT nodomain
 
 	(t,i,a) <- noteT' invalidAccount $ parseAccountNumbers account
+
+	(samnt:currency:_) <- T.splitOn (s"/") <$> fromQ "amount"
+	when (currency /= s"CAD") $ throwT invalidCurrency
+	amnt <- noteT' (FederationError InvalidParams "Invalid amount") (readMay samnt)
+
 	Vgg.UUID uuid <- fmap Vgg.uuid $ fmapLT apiErr $ EitherT $ liftIO $
 		VggC.createAccount vgg $
 			VggC.BankAccount (T.unpack account) t i a (read $ s"CAD")
@@ -57,19 +94,15 @@ federationEndpoint root db vgg rAddr req = eitherT err return $ do
 			fst <$> insertSucc db (s"INSERT INTO accounts VALUES(?,?)")
 				(first succ) (rdt, uuid)
 
-	json ok200 [cors] (Alias account domain rAddr (Just $ fromInteger dt))
+	json ok200 [cors] (Quote rAddr (fromInteger dt) (amnt + fee, "CAD"))
+
 	where
 	query' sql = liftIO . query db (s sql)
 
-	err e@(FederationError NoSuchUser _) = json notFound404 [cors] e
-	err e = json badRequest400 [cors] e
-
 	apiErr Vgg.APIParamError = FederationError InvalidParams "Invalid account"
 	apiErr _ = FederationError Unavailable "Something went wrong"
 
 	Just rootDomain = T.pack . uriRegName <$> uriAuthority root
-	nodomain = FederationError NoSuchDomain "That domain is not served here."
-	invalidAccount = FederationError NoSuchUser "Invalid account numbers."
 	fromQ k = noteT' (FederationError InvalidParams ("No "++k++" provided.")) $
 		queryLookup k (queryString req)
 

Makefile

@@ -1,4 +1,4 @@
-Main: Main.hs Application.hs Routes.hs MustacheTemplates.hs PathHelpers.hs
+Main: Main.hs Application.hs Routes.hs PathHelpers.hs
 	ghc -threaded -O2 -Wall -fno-warn-name-shadowing Main.hs
 
 Routes.hs: routes

Records.hs

@@ -50,10 +50,6 @@ instance FromRow Deposit where
 				Just ripple -> Ok ripple
 			_ -> Errors [toException $ ConversionFailed "TEXT" "RippleAddress" "need a text"]
 
-instance ToRow Quote where
-	toRow (Quote qid typ amnt dest email q a msg complete) =
-		[toField qid, toField typ, toField amnt, toField (show dest), toField (show email), toField q, toField a, toField msg, toField complete]
-
 instance (CanVerify a) => ToRow (Verification a) where
 	toRow (Verification item typ notes token) = [
 			toField itemId,
@@ -68,9 +64,6 @@ instance (CanVerify a) => ToRow (Verification a) where
 instance ToField VerificationType where
 	toField = toField . show
 
-instance ToField QuoteType where
-	toField = toField . show
-
 class CanVerify a where
 	verifyItemData :: a -> (Int64, String)
 
@@ -121,26 +114,6 @@ data PlivoDeposit = PlivoDeposit {
 		plivoCode :: String
 	}
 
-data QuoteType = InteracETransferQuote
-	deriving (Show, Read, Enum)
-
-data Quote = Quote {
-		quoteId          :: Word32, -- Because destination tag
-		quoteType        :: QuoteType,
-		quoteAmount      :: Double,
-		quoteDestination :: EmailAddress,
-		quotorEmail      :: EmailAddress,
-		quoteQuestion    :: Text,
-		quoteAnswer      :: Text,
-		quoteMessage     :: Text,
-		quoteComplete    :: Bool
-	}
-
-data QuoteSuccess = QuoteSuccess {
-		successfulQuote :: [Quote],
-		quoteHomeLink :: URI
-	}
-
 data PlivoConfig = PlivoConfig {
 		plivoAuthId    :: String,
 		plivoAuthToken :: String,
@@ -182,6 +155,39 @@ instance ToJSON Alias where
 			] ++ maybe [] (\x -> [s"dt" .= x]) dt)
 		]
 
+data ShouldQuote = ShouldQuote Text Text URI
+
+instance ToJSON ShouldQuote where
+	toJSON (ShouldQuote alias domain quoteURI) = object [
+		s"federation_json" .= object [
+				s"type" .= "federation_record",
+				s"destination" .= alias,
+				s"domain" .= domain,
+				s"quote_url" .= show quoteURI,
+				s"currencies" .= [object [s"currency" .= "CAD"]]
+			]
+		]
+
+data Quote = Quote {
+		quoteRipple :: RippleAddress,
+		quoteDT     :: Word32,
+		quoteAmount :: (Double, String)
+	}
+
+instance ToJSON Quote where
+	toJSON (Quote ripple dt (amount,currency)) = object [
+		s"federation_json" .= object [
+			s"result" .= "success",
+			s"quote" .= object [
+				s"address" .= show ripple,
+				s"destination_tag" .= dt,
+				s"send" .= [object [
+					s"currency" .= currency,
+					s"value" .= show amount
+				]]
+			]
+		]]
+
 instance ToJSON FederationError where
 	toJSON (FederationError typ message) = object [
 			s"result" .= "error",

routes

@@ -1 +1,2 @@
 GET /federation => federationEndpoint
+GET /federation/quote => quoteEndpoint