{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}

-- | https://www.europeanpaymentscouncil.eu/sites/default/files/kb/file/2022-06/EPC130-08%20SDD%20Core%20C2PSP%20IG%202023%20V1.0.pdf
--   this is some xml format the accountents asked support for
module SnelstartImport.SepaDirectCoreScheme
  ( SepaDirectCoreScheme(..)
  , readSepaDirectCoreScheme
  )
where

import SnelstartImport.Currency
import Text.XML.Hexml(parse, children, name, Node, inner)
import Data.Text (Text)
import Data.ByteString (ByteString)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as Text
import Data.List
import Data.Bifunctor(first)
import Text.Read(readMaybe)
import Data.Time(Day, parseTimeM, defaultTimeLocale)

data SepaDirectCoreScheme = SepaDirectCoreScheme {
  -- -- | Unambiguous identification of the account of the
  -- -- creditor to which a credit entry will be posted as a
  -- -- result of the payment transaction.
  -- cdtrAcct :: Text,
  SepaDirectCoreScheme -> Text
endToEndId :: Text,
  SepaDirectCoreScheme -> Text
dbtrAcct :: Text,
  SepaDirectCoreScheme -> Text
dbtr :: Text,
  SepaDirectCoreScheme -> Currency
instdAmt :: Currency,
  SepaDirectCoreScheme -> Day
dtOfSgntr :: Day
  } deriving Int -> SepaDirectCoreScheme -> ShowS
[SepaDirectCoreScheme] -> ShowS
SepaDirectCoreScheme -> String
(Int -> SepaDirectCoreScheme -> ShowS)
-> (SepaDirectCoreScheme -> String)
-> ([SepaDirectCoreScheme] -> ShowS)
-> Show SepaDirectCoreScheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SepaDirectCoreScheme -> ShowS
showsPrec :: Int -> SepaDirectCoreScheme -> ShowS
$cshow :: SepaDirectCoreScheme -> String
show :: SepaDirectCoreScheme -> String
$cshowList :: [SepaDirectCoreScheme] -> ShowS
showList :: [SepaDirectCoreScheme] -> ShowS
Show

name_ :: Node -> Text
name_ :: Node -> Text
name_ = Text -> Text
Text.toLower (Text -> Text) -> (Node -> Text) -> Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Node -> ByteString) -> Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ByteString
name

dig :: Text -> Node -> [Node]
dig :: Text -> Node -> [Node]
dig Text
tag Node
parent = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Node
x -> Node -> Text
name_ Node
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
Text.toLower Text
tag) ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
children Node
parent

data SepaParseErrors = ParseXmlError ByteString
                     | SepaParseIssues SepaIssues
                     deriving Int -> SepaParseErrors -> ShowS
[SepaParseErrors] -> ShowS
SepaParseErrors -> String
(Int -> SepaParseErrors -> ShowS)
-> (SepaParseErrors -> String)
-> ([SepaParseErrors] -> ShowS)
-> Show SepaParseErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SepaParseErrors -> ShowS
showsPrec :: Int -> SepaParseErrors -> ShowS
$cshow :: SepaParseErrors -> String
show :: SepaParseErrors -> String
$cshowList :: [SepaParseErrors] -> ShowS
showList :: [SepaParseErrors] -> ShowS
Show

readSepaDirectCoreScheme :: ByteString -> Either SepaParseErrors [SepaDirectCoreScheme]
readSepaDirectCoreScheme :: ByteString -> Either SepaParseErrors [SepaDirectCoreScheme]
readSepaDirectCoreScheme ByteString
contents = do
  Node
nodeRes <- (ByteString -> SepaParseErrors)
-> Either ByteString Node -> Either SepaParseErrors Node
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> SepaParseErrors
ParseXmlError (Either ByteString Node -> Either SepaParseErrors Node)
-> Either ByteString Node -> Either SepaParseErrors Node
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString Node
parse ByteString
contents

  (Node -> Either SepaParseErrors SepaDirectCoreScheme)
-> [Node] -> Either SepaParseErrors [SepaDirectCoreScheme]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((SepaIssues -> SepaParseErrors)
-> Either SepaIssues SepaDirectCoreScheme
-> Either SepaParseErrors SepaDirectCoreScheme
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SepaIssues -> SepaParseErrors
SepaParseIssues (Either SepaIssues SepaDirectCoreScheme
 -> Either SepaParseErrors SepaDirectCoreScheme)
-> (Node -> Either SepaIssues SepaDirectCoreScheme)
-> Node
-> Either SepaParseErrors SepaDirectCoreScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Either SepaIssues SepaDirectCoreScheme
parseSepa) (((Text -> Node -> [Node]
dig Text
"DrctDbtTxInf")) (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Text -> Node -> [Node]
dig Text
"PmtInf") (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Text -> Node -> [Node]
dig Text
"CstmrDrctDbtInitn") (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"document" Node
nodeRes)))
--

data SepaIssues = ExpectedOne [Node] Text
                | ExpectedNumber Node Text
                | ExpectedDate Node Text
                deriving Int -> SepaIssues -> ShowS
[SepaIssues] -> ShowS
SepaIssues -> String
(Int -> SepaIssues -> ShowS)
-> (SepaIssues -> String)
-> ([SepaIssues] -> ShowS)
-> Show SepaIssues
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SepaIssues -> ShowS
showsPrec :: Int -> SepaIssues -> ShowS
$cshow :: SepaIssues -> String
show :: SepaIssues -> String
$cshowList :: [SepaIssues] -> ShowS
showList :: [SepaIssues] -> ShowS
Show


assertOne :: Text -> [Node] -> Either SepaIssues Node
assertOne :: Text -> [Node] -> Either SepaIssues Node
assertOne Text
label [Node]
nodes =
  case [Node] -> Maybe (Node, [Node])
forall a. [a] -> Maybe (a, [a])
uncons [Node]
nodes of
    Just (Node
x, [Node]
_) -> Node -> Either SepaIssues Node
forall a b. b -> Either a b
Right Node
x
    Maybe (Node, [Node])
Nothing -> SepaIssues -> Either SepaIssues Node
forall a b. a -> Either a b
Left ([Node] -> Text -> SepaIssues
ExpectedOne [Node]
nodes Text
label)

inner_ :: Node -> Text
inner_ :: Node -> Text
inner_ = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Node -> ByteString) -> Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ByteString
inner

parseCurrency :: Node -> Either SepaIssues Currency
parseCurrency :: Node -> Either SepaIssues Currency
parseCurrency Node
node = case String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack (Node -> Text
inner_ Node
node)) of
  Just Double
number -> Currency -> Either SepaIssues Currency
forall a b. b -> Either a b
Right (Currency -> Either SepaIssues Currency)
-> Currency -> Either SepaIssues Currency
forall a b. (a -> b) -> a -> b
$ Double -> Currency
Currency Double
number
  Maybe Double
Nothing -> SepaIssues -> Either SepaIssues Currency
forall a b. a -> Either a b
Left (Node -> Text -> SepaIssues
ExpectedNumber Node
node (Node -> Text
inner_ Node
node))

parseDay :: Node -> Either SepaIssues Day
parseDay :: Node -> Either SepaIssues Day
parseDay Node
node = case Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%F" (Text -> String
Text.unpack (Node -> Text
inner_ Node
node)) of
  Maybe Day
Nothing -> SepaIssues -> Either SepaIssues Day
forall a b. a -> Either a b
Left (SepaIssues -> Either SepaIssues Day)
-> SepaIssues -> Either SepaIssues Day
forall a b. (a -> b) -> a -> b
$ Node -> Text -> SepaIssues
ExpectedDate Node
node (Node -> Text
inner_ Node
node)
  Just Day
day -> Day -> Either SepaIssues Day
forall a b. b -> Either a b
Right Day
day

parseSepa :: Node -> Either SepaIssues SepaDirectCoreScheme
parseSepa :: Node -> Either SepaIssues SepaDirectCoreScheme
parseSepa Node
node = do
  Text
dbtr <- Node -> Text
inner_ (Node -> Text) -> Either SepaIssues Node -> Either SepaIssues Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Node] -> Either SepaIssues Node
assertOne Text
"dbtr" (Text -> Node -> [Node]
dig Text
"nm" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"dbtr" Node
node)
  Text
dbtrAcct <- Node -> Text
inner_ (Node -> Text) -> Either SepaIssues Node -> Either SepaIssues Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Node] -> Either SepaIssues Node
assertOne Text
"dbtracct" (Text -> Node -> [Node]
dig Text
"IBAN" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"Id" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"DbtrAcct" Node
node)
  Text
endToEndId <- Node -> Text
inner_ (Node -> Text) -> Either SepaIssues Node -> Either SepaIssues Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Node] -> Either SepaIssues Node
assertOne Text
"endToEndId" (Text -> Node -> [Node]
dig Text
"EndToEndId" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"PmtId" Node
node)
  Currency
instdAmt <- Node -> Either SepaIssues Currency
parseCurrency (Node -> Either SepaIssues Currency)
-> Either SepaIssues Node -> Either SepaIssues Currency
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Node] -> Either SepaIssues Node
assertOne Text
"instdAmt" (Text -> Node -> [Node]
dig Text
"instdAmt" Node
node)
  Day
dtOfSgntr <- Node -> Either SepaIssues Day
parseDay (Node -> Either SepaIssues Day)
-> Either SepaIssues Node -> Either SepaIssues Day
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Node] -> Either SepaIssues Node
assertOne Text
"dtOfSgntr" (Text -> Node -> [Node]
dig Text
"DtOfSgntr" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"MndtRltdInf" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"DrctDbtTx" Node
node)
  SepaDirectCoreScheme -> Either SepaIssues SepaDirectCoreScheme
forall a b. b -> Either a b
Right (SepaDirectCoreScheme -> Either SepaIssues SepaDirectCoreScheme)
-> SepaDirectCoreScheme -> Either SepaIssues SepaDirectCoreScheme
forall a b. (a -> b) -> a -> b
$ SepaDirectCoreScheme {
    Text
Day
Currency
endToEndId :: Text
dbtrAcct :: Text
dbtr :: Text
instdAmt :: Currency
dtOfSgntr :: Day
dbtr :: Text
dbtrAcct :: Text
endToEndId :: Text
instdAmt :: Currency
dtOfSgntr :: Day
..
    }