Support the extra_fields stuff

Federation.hs

@@ -4,7 +4,7 @@ module Federation (federationEndpoint, quoteEndpoint) where
 import Prelude ()
 import BasicPrelude
 import Data.Fixed (Centi)
-import Control.Error (eitherT, MaybeT(..), throwT, noteT)
+import Control.Error (eitherT, MaybeT(..), throwT, noteT, atMay)
 import qualified Data.Text as T
 
 import Network.Wai (Application, Response, queryString)
@@ -29,12 +29,12 @@ import Account
 
 Just [cors] = stringHeaders [("Access-Control-Allow-Origin", "*")]
 
-parseAccountNumbers :: Text -> Maybe (String,String,String)
+parseAccountNumbers :: Text -> Maybe (Text,Text,Text)
 parseAccountNumbers t
 	| length pieces /= 3 = Nothing
 	| T.length i /= 3 = Nothing
 	| otherwise = let [t,i,a] = pieces in
-		Just (T.unpack t, T.unpack i, T.unpack a)
+		Just (t, i, a)
 	where
 	pieces@(_:i:_) = T.splitOn (s"-") t
 
@@ -53,35 +53,37 @@ invalidCurrency = FederationError InvalidParams "Invalid currency"
 
 federationEndpoint :: Action Application
 federationEndpoint root _ _ _ req = eitherT err return $ do
-	(domain,account) <- (,) <$> fromQ "domain" <*> fromQ "destination"
+	domain <- fromQ "domain"
 	when (domain /= rootDomain) $ throwT nodomain
 
-	(_,_,_) <- noteT' invalidAccount $ parseAccountNumbers account
-
-	json ok200 [cors] (ShouldQuote account domain (quoteEndpointPath `relativeTo` root))
+	json ok200 [cors] (ShouldQuote destination domain (quoteEndpointPath `relativeTo` root) (atMay pieces 0, atMay pieces 1, atMay pieces 2))
 	where
+	destination = fromMaybe T.empty $ fromQ' "destination"
+	pieces = T.splitOn (s"-") destination
 	Just rootDomain = T.pack . uriRegName <$> uriAuthority root
+	fromQ' k = queryLookup k (queryString req)
 	fromQ k = noteT' (FederationError InvalidParams ("No "++k++" provided.")) $
-		queryLookup k (queryString req)
+		fromQ' k
 
 quoteEndpoint :: Action Application
 quoteEndpoint _ db vgg rAddr req = eitherT err return $ do
-	account <- fromQ "destination"
-
 	{- Current client does not send domain for quote request
 	(domain,account) <- (,) <$> fromQ "domain" <*> fromQ "destination"
 	when (domain /= rootDomain) $ throwT nodomain
 	-}
 
-	(t,i,a) <- noteT' invalidAccount $ parseAccountNumbers account
+	(t',i',a') <- case fromQ' "transit" of
+		(Just t) -> (,,) <$> pure t <*> fromQ "institution" <*> fromQ "account"
+		Nothing -> fromQ "destination" >>= noteT' invalidAccount . parseAccountNumbers
+	let (t,i,a) = (T.unpack t', T.unpack i', T.unpack a')
 
 	(samnt:currency:_) <- T.splitOn (s"/") <$> fromQ "amount"
 	when (currency /= s"CAD") $ throwT invalidCurrency
 	amnt <- noteT' (FederationError InvalidParams "Invalid amount")
 		(realToFrac <$> (readMay samnt :: Maybe Centi))
 
 	(dt,lim) <- noteT (FederationError InvalidParams "Invalid account") $ MaybeT$
-		fetchDT db vgg t i a (T.unpack account)
+		fetchDT db vgg t i a (t ++ "-" ++ i ++ "-" ++ a)
 
 	when (amnt > fromIntegral lim) $
 		throwT $ FederationError InvalidParams "Over limit"
@@ -92,5 +94,6 @@ quoteEndpoint _ db vgg rAddr req = eitherT err return $ do
 	where
 	query' sql = liftIO . query db (s sql)
 
+	fromQ' k = queryLookup k (queryString req)
 	fromQ k = noteT' (FederationError InvalidParams ("No "++k++" provided.")) $
-		queryLookup k (queryString req)
+		fromQ' k

Records.hs

@@ -99,16 +99,39 @@ instance ToJSON Alias where
 			] ++ maybe [] (\x -> [s"dt" .= x]) dt)
 		]
 
-data ShouldQuote = ShouldQuote Text Text URI
+data ShouldQuote = ShouldQuote Text Text URI (Maybe Text, Maybe Text, Maybe Text)
 
 instance ToJSON ShouldQuote where
-	toJSON (ShouldQuote alias domain quoteURI) = object [
+	toJSON (ShouldQuote alias domain quoteURI (transit,inst,acct)) = 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"]]
+				s"currencies" .= [object [s"currency" .= "CAD"]],
+				s"extra_fields" .= [
+					object [
+						s"label"    .= "Transit Number",
+						s"name"     .= "transit",
+						s"required" .= True,
+						s"type"     .= "number",
+						s"value"    .= fromMaybe mempty transit
+					],
+					object [
+						s"label"    .= "Institution Number",
+						s"name"     .= "institution",
+						s"required" .= True,
+						s"type"     .= "number",
+						s"value"    .= fromMaybe mempty inst
+					],
+					object [
+						s"label"    .= "Account Number",
+						s"name"     .= "account",
+						s"required" .= True,
+						s"type"     .= "number",
+						s"value"    .= fromMaybe mempty acct
+					]
+				]
 			]
 		]