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

-- | 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(..)
  , SepaDirectCoreResults(..)
  , SepaGlobals(..)
  , 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(UTCTime, Day, parseTimeM, defaultTimeLocale)
import Data.Time.Format.ISO8601
import Data.Time.LocalTime(zonedTimeToUTC)

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, -- | bank number
  SepaDirectCoreScheme -> Text
dbtr :: Text, -- | name of person sending
  SepaDirectCoreScheme -> Currency
instdAmt :: Currency,
  SepaDirectCoreScheme -> Day
dtOfSgntr :: Day, -- | this is not the actual transaction date
  SepaDirectCoreScheme -> Text
rmtInf :: Text -- | invoice number
  } 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

data SepaGlobals = SepaGlobals {
  SepaGlobals -> UTCTime
creDtTm :: UTCTime,
  SepaGlobals -> Text
cdtrAcct :: Text
  }

data SepaDirectCoreResults = SepaDirectCoreResults {
  SepaDirectCoreResults -> [SepaDirectCoreScheme]
sdcrRows :: [SepaDirectCoreScheme],
  SepaDirectCoreResults -> SepaGlobals
sdcrGlob :: SepaGlobals
  }

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 SepaDirectCoreResults
readSepaDirectCoreScheme :: ByteString -> Either SepaParseErrors SepaDirectCoreResults
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
mainNode :: Node <- (SepaIssues -> SepaParseErrors)
-> Either SepaIssues 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 SepaIssues -> SepaParseErrors
SepaParseIssues (Either SepaIssues Node -> Either SepaParseErrors Node)
-> Either SepaIssues Node -> Either SepaParseErrors Node
forall a b. (a -> b) -> a -> b
$ Text -> [Node] -> Either SepaIssues Node
assertOne Text
"CstmrDrctDbtInitn" ((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)

  SepaGlobals
sdcrGlob <- (SepaIssues -> SepaParseErrors)
-> Either SepaIssues SepaGlobals
-> Either SepaParseErrors SepaGlobals
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 SepaGlobals
 -> Either SepaParseErrors SepaGlobals)
-> Either SepaIssues SepaGlobals
-> Either SepaParseErrors SepaGlobals
forall a b. (a -> b) -> a -> b
$ Node -> Either SepaIssues SepaGlobals
parseGlobals Node
mainNode

  [SepaDirectCoreScheme]
sdcrRows <- (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) ([Node] -> Either SepaParseErrors [SepaDirectCoreScheme])
-> [Node] -> Either SepaParseErrors [SepaDirectCoreScheme]
forall a b. (a -> b) -> a -> b
$ ((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
mainNode )

  SepaDirectCoreResults
-> Either SepaParseErrors SepaDirectCoreResults
forall a. a -> Either SepaParseErrors a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SepaDirectCoreResults
 -> Either SepaParseErrors SepaDirectCoreResults)
-> SepaDirectCoreResults
-> Either SepaParseErrors SepaDirectCoreResults
forall a b. (a -> b) -> a -> b
$ SepaDirectCoreResults {[SepaDirectCoreScheme]
SepaGlobals
sdcrRows :: [SepaDirectCoreScheme]
sdcrGlob :: SepaGlobals
sdcrGlob :: SepaGlobals
sdcrRows :: [SepaDirectCoreScheme]
..}
--

data SepaIssues = ExpectedOne [Node] Text
                | ExpectedNumber Node Text
                | ExpectedDate Node Text
                | ExpectedTime 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

parseGlobals :: Node -> Either SepaIssues SepaGlobals
parseGlobals :: Node -> Either SepaIssues SepaGlobals
parseGlobals Node
node = do
  UTCTime
creDtTm <- Node -> Either SepaIssues UTCTime
parseTime (Node -> Either SepaIssues UTCTime)
-> Either SepaIssues Node -> Either SepaIssues UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Node] -> Either SepaIssues Node
assertOne Text
"CreDtTm" (Text -> Node -> [Node]
dig Text
"CreDtTm" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"GrpHdr" Node
node)
  Text
cdtrAcct <- 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
"CdtrAcct" (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
"CdtrAcct" (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)
  SepaGlobals -> Either SepaIssues SepaGlobals
forall a. a -> Either SepaIssues a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SepaGlobals -> Either SepaIssues SepaGlobals)
-> SepaGlobals -> Either SepaIssues SepaGlobals
forall a b. (a -> b) -> a -> b
$ SepaGlobals {Text
UTCTime
creDtTm :: UTCTime
cdtrAcct :: Text
creDtTm :: UTCTime
cdtrAcct :: Text
..}

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

parseTime :: Node -> Either SepaIssues UTCTime
parseTime :: Node -> Either SepaIssues UTCTime
parseTime Node
node = case ZonedTime -> UTCTime
zonedTimeToUTC (ZonedTime -> UTCTime) -> Maybe ZonedTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe ZonedTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM (Text -> String
Text.unpack (Node -> Text
inner_ Node
node)) of
  Maybe UTCTime
Nothing -> SepaIssues -> Either SepaIssues UTCTime
forall a b. a -> Either a b
Left (SepaIssues -> Either SepaIssues UTCTime)
-> SepaIssues -> Either SepaIssues UTCTime
forall a b. (a -> b) -> a -> b
$ Node -> Text -> SepaIssues
ExpectedTime Node
node (Node -> Text
inner_ Node
node)
  Just UTCTime
day -> UTCTime -> Either SepaIssues UTCTime
forall a b. b -> Either a b
Right UTCTime
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)
  Text
rmtInf <- 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
"RmtInf" (Text -> Node -> [Node]
dig Text
"Ustrd" (Node -> [Node]) -> [Node] -> [Node]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Node -> [Node]
dig Text
"RmtInf" 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
rmtInf :: Text
dbtr :: Text
dbtrAcct :: Text
endToEndId :: Text
instdAmt :: Currency
dtOfSgntr :: Day
rmtInf :: Text
..
    }