commit a94049938aebfc22f1048fd3cf0c209bcea160e5
parent aa0e8eedb655d84a40b8f3161d79e53ec312dcb2
Author: Vint Leenaars <vl.software@leenaa.rs>
Date: Thu, 8 May 2025 22:55:02 +0200
Read JSON input
Diffstat:
2 files changed, 73 insertions(+), 18 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
@@ -10,12 +10,16 @@ module Main (main) where
import Control.Exception
import Control.Monad (when)
+import Data.Aeson (eitherDecode)
+import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Time
import qualified Data.Text as T
import Dhall
+import KYCheck.Check
import KYCheck.Config
import KYCheck.Error
+import KYCheck.GLS.Type
import KYCheck.SSL
import KYCheck.SSL.XML.Type
import KYCheck.Type
@@ -26,14 +30,18 @@ import System.Directory
import System.FilePath
-getJSON :: Targets -> IO ()
-getJSON sanction_list = do
- print "JSON:"
+readJSON :: Config -> Targets -> IO ()
+readJSON config sanction_list = do
+ when (verbosity config >= Info) $ print "Sanction list loaded, please input your JSON"
line <- getLine
if line == "quit"
then print "Leaving KYCheck"
- else do print line
- getJSON sanction_list
+ else do case (eitherDecode . BLC.pack) line of
+ Left err -> print $ "Could not decode JSON (" ++ show err ++ "), please try again"
+ Right entry -> case entry of
+ NP person -> mapM_ print $ checkPersons config (individuals sanction_list) person
+ LE entity -> mapM_ print $ checkEntity config (entities sanction_list) entity
+ readJSON config sanction_list
main :: IO ()
main = do
@@ -43,7 +51,7 @@ main = do
Nothing -> return ()
Just Silent -> return ()
Just _ -> do curr_dir <- getCurrentDirectory
- putStrLn $ "Searching for 'kycheck.conf' in " ++ curr_dir
+ putStrLn $ "Searching for 'kycheck.conf in " ++ curr_dir
dhall <- input auto "./kycheck.conf" :: IO DhallConfig
let config = inputToConfig dhall $ Just cl
@@ -62,6 +70,9 @@ main = do
Left err -> do curr_dir <- getCurrentDirectory
_ <- handleError v $ Left $ KYCheck_InvalidXML (T.pack $ curr_dir </> ssl_location config) (show err)
return ()
- Right xml -> do getJSON $ xmlToSSL xml
- time_to_parse_ssl <- getCurrentTime
- print $ "Time to parse sanctions: " ++ (show $ diffUTCTime time_to_parse_ssl start)
+ Right xml -> do let tgts = xmlToSSL xml
+ case start_date tgts of
+ Just age -> print $ "Seconds since epoch: " ++ (show $ floor $ diffUTCTime start (UTCTime age 0))
+ Nothing -> print $ "Could not find age of sanction_list"
+
+ readJSON config tgts
diff --git a/src/KYCheck/GLS/Type.hs b/src/KYCheck/GLS/Type.hs
@@ -5,6 +5,10 @@
-- | See https://git.taler.net/gana.git/tree/gnu-taler-form-attributes/registry.rec
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module KYCheck.GLS.Type
( Address(..)
, Entry(..)
@@ -12,14 +16,18 @@ module KYCheck.GLS.Type
, NaturalPerson(..)
) where
--- import Data.Aeson (FromJSON(..), ToJSON(..), (.=), object, Value(..))
-import Data.CountryCodes
+import Control.Applicative ((<|>))
+
+import Data.Aeson
+import Data.CountryCodes hiding (NP)
import Data.Text
import Data.Time.Calendar.OrdinalDate
+import GHC.Generics
+
data Entry = NP NaturalPerson
- | LE
- | F deriving (Show, Eq)
+ | LE LegalEntity deriving (Show, Generic, Eq)
+ -- | F
data NaturalPerson = NaturalPerson
{ full_name :: Text
@@ -35,7 +43,7 @@ data NaturalPerson = NaturalPerson
-- , registered_office :: Maybe Text
-- , company_id :: Maybe Text
-- , company_id_copy :: Maybe FilePath
- } deriving (Show, Eq)
+ } deriving (Show, Eq, Generic)
data Address = Address
{ country :: CountryCode -- 2-letter ISO country-code
@@ -48,9 +56,7 @@ data Address = Address
, town_location :: Maybe Text
, town_district :: Maybe Text
, country_subdivision :: Maybe Text
- } deriving (Show, Eq)
-
-
+ } deriving (Show, Eq, Generic)
data LegalEntity = LegalEntity
{ company_name :: Text
@@ -60,7 +66,45 @@ data LegalEntity = LegalEntity
, email :: Maybe Text
, id :: Text
-- , id_copy :: FilePath
- } deriving (Show, Eq)
+ } deriving (Show, Eq, Generic)
+
+instance FromJSON Entry where
+ parseJSON e =
+ (NP <$> parseJSON e)
+ <|> (LE <$> parseJSON e)
+instance FromJSON NaturalPerson where
+ parseJSON = withObject "natural_person" $ \p ->
+ NaturalPerson <$> p .: "full_name"
+ <*> p .: "last_name"
+ <*> p .: "residential"
+ <*> p .: "birthdate"
+ <*> p .: "nationality"
+ <*> p .: "text"
+instance FromJSON Address where
+ parseJSON = withObject "address" $ \a ->
+ Address <$> a .: "country"
+ <*> a .: "street_name"
+ <*> a .: "street_number"
+ <*> a .:? "lines"
+ <*> a .:? "building_name"
+ <*> a .:? "building_number"
+ <*> a .: "zipcode"
+ <*> a .:? "town_location"
+ <*> a .:? "town_district"
+ <*> a .:? "country_subdivision"
+instance FromJSON LegalEntity where
+ parseJSON = withObject "legal_entity" $ \e ->
+ LegalEntity <$> e .: "company_name"
+ <*> e .: "address"
+ <*> e .:? "contact_person_name"
+ <*> e .:? "phone"
+ <*> e .:? "email"
+ <*> e .: "id"
+
+instance ToJSON Entry
+instance ToJSON NaturalPerson
+instance ToJSON Address
+instance ToJSON LegalEntity
-- data Founder = Founder
-- { full_name :: Text
