diff --git a/Application.hs b/Application.hs index 5d29825..9b65b88 100644 --- a/Application.hs +++ b/Application.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -module Application (federationEndpoint) where +module Application (federationEndpoint, quoteEndpoint) where import Prelude () import BasicPrelude @@ -9,7 +9,7 @@ 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) @@ -17,6 +17,7 @@ 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) @@ -24,6 +25,9 @@ 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) diff --git a/Makefile b/Makefile index 97ba07b..933b054 100644 --- a/Makefile +++ b/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 diff --git a/Records.hs b/Records.hs index 0bfdc6b..0aa43a0 100644 --- a/Records.hs +++ b/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", diff --git a/routes b/routes index 02680a5..5735e65 100644 --- a/routes +++ b/routes @@ -1 +1,2 @@ GET /federation => federationEndpoint +GET /federation/quote => quoteEndpoint