commit 53ec32cf745a27c4b6a91da79c7774e57b9e3400
parent ec1fdaa08298c0c6bdb108eafd885b98b590cfae
Author: Christian Grothoff <christian@grothoff.org>
Date: Thu, 5 Jun 2025 11:46:43 +0200
change score printing to match expectations of taler-exchange-sanctionscheck
Diffstat:
2 files changed, 32 insertions(+), 21 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
@@ -31,9 +31,12 @@ import System.IO
import Toml (decodeFile)
+printScores :: [Score] -> IO ()
+printScores scores = mapM_ (putStrLn . scoreToString) scores
+
+
readJSON :: Config -> Targets -> IO ()
readJSON config sanction_list = do
- when (verbosity config >= Info) $ hPutStrLn stderr "Sanction list loaded. Ready for your input.\n(Paste subject data into the terminal. Use JSONlines format.)\nType 'CTRL-D' to exit."
eof <- isEOF
if eof
then hPutStrLn stderr "Thank you for using Robocop."
@@ -43,8 +46,8 @@ readJSON config sanction_list = do
Left err -> hPutStrLn stderr $ "Failed to decode JSON (" ++ show err ++ ")"
Right entry -> do
case entry of
- NP person -> mapM_ print $ checkPersons config (individuals sanction_list) person
- LE entity -> mapM_ print $ checkEntity config (entities sanction_list) entity
+ NP person -> printScores $ checkPersons config (individuals sanction_list) person
+ LE entity -> printScores $ checkEntity config (entities sanction_list) entity
readJSON config sanction_list
main :: IO ()
@@ -83,4 +86,5 @@ main = do
Just age -> hPutStrLn stderr $ "Seconds since epoch: " ++ (show (floor $ diffUTCTime start (UTCTime age 0) :: Int))
Nothing -> hPutStrLn stderr $ "Could not find age of sanction list"
+ when (verbosity config >= Info) $ hPutStrLn stderr "Sanction list loaded. Ready for your input.\n(Paste subject data into the terminal. Use JSONlines format.)\nType 'CTRL-D' to exit."
readJSON config tgts
diff --git a/src/Robocop/Check.hs b/src/Robocop/Check.hs
@@ -16,6 +16,7 @@ module Robocop.Check
, compareFullDate
, multFloats
, Score(..)
+ , scoreToString
) where
import Data.ISO3166_CountryCodes
@@ -24,15 +25,17 @@ import Data.Maybe
import Data.Map (Map, toList)
import Data.Ratio
-import Data.Text (intercalate, pack, snoc, Text)
+import Data.Text (intercalate, pack, snoc, Text)
import qualified Data.Text as T
import Data.Text.Metrics
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
+import Text.Printf (printf)
+
import Robocop.Type
-import Robocop.SSL.Type as SSL
+import Robocop.SSL.Type as SSL
import Robocop.GLS.Type as GLS
import Prelude hiding (lines)
@@ -44,6 +47,10 @@ data Score = Score
, reference :: Int
} deriving (Show, Eq)
+scoreToString :: Score -> String
+scoreToString (Score mq conf expiresec ref) =
+ printf "%f %f %d %d" mq conf expiresec ref
+
suspicious_dates :: (Int, Int)
suspicious_dates = (3, 75) -- Difference in years and days that will be marked suspicious (exponential)
@@ -56,7 +63,7 @@ checkEntity config entities' entity = findMatchingEntities config entity $ toLis
findMatchingEntities :: Config -> LegalEntity -> [(Int, Entity)] -> [Score]
findMatchingEntities _ _ [] = []
-findMatchingEntities config entity ((ssid,ent):ents) =
+findMatchingEntities config entity ((ssid,ent):ents) =
let
points = compareEntity config entity ent
max_points = foldl1 (+) [ if toList (entity_addresses ent) == [] then 0 else weight_address config
@@ -67,7 +74,7 @@ findMatchingEntities config entity ((ssid,ent):ents) =
then let
score = Score { match_quality = if points >= perfect_points config then 1 else points / perfect_points config
, confidence = points / max_points
- , expiration = 0
+ , expiration = 0
, reference = ssid
}
in
@@ -91,7 +98,7 @@ checkPersons :: Config -> Map Int Individual -> NaturalPerson -> [Score]
checkPersons config individuals' person = checkPersons' config person $ toList individuals'
checkPersons' :: Config -> NaturalPerson -> [(Int, Individual)] -> [Score]
-checkPersons' _ _ [] = []
+checkPersons' _ _ [] = []
checkPersons' config person ((ssid,ind):inds) =
let
points = checkPerson config person ind
@@ -108,7 +115,7 @@ checkPersons' config person ((ssid,ind):inds) =
, confidence = points / max_points
, expiration = 0
, reference = ssid
- }
+ }
in
score:checkPersons' config person inds
else checkPersons' config person inds
@@ -119,11 +126,11 @@ checkPerson config person individual = foldl1 (+) [ address_points
, multFloats 100 date_score (removeQuality . removeSSID)
, 50 * nationality_score
, name_points
- ]
- where address_score = checkAddress config (addresses individual) (residential person)
+ ]
+ where address_score = checkAddress config (addresses individual) (residential person)
id_score = checkID config (ids individual) (national_id person)
nationality_score = checkCountryCode config (nationalities individual) (nationality person)
- name_score = checkNames config (names individual) (full_name person)
+ name_score = checkNames config (names individual) (full_name person)
date_score = if name_points == 0
then []
else checkBirthDate config (birth_dates individual) (birthdate person)
@@ -148,7 +155,7 @@ checkBirthDate config dates (Day' date) = catMaybes $ map compareDate $ toList d
then Just $ WithSSID ssid $ liftQuality (\_ -> ratio) quality
else Nothing
-compareFullDate :: Config -> Year -> DayOfYear -> Day -> Float
+compareFullDate :: Config -> Year -> DayOfYear -> Day -> Float
compareFullDate config year day_of_year day = max ratio_text ratio_date
where day' = fromOrdinalDate year day_of_year
day_to_text d = pack $ showGregorian d
@@ -177,7 +184,7 @@ compareYear config year day = if ratio >= threshold then ratio else 0
-checkNames :: Config -> Map Int (Quality [Text]) -> Text -> [WithSSID QualityFloat]
+checkNames :: Config -> Map Int (Quality [Text]) -> Text -> [WithSSID QualityFloat]
checkNames config names' name = catMaybes $ map compareName $ toList names'
where compareName (ssid, quality) = let
ratio = ratioToFloat $ compareText name 0 (removeQuality quality)
@@ -206,18 +213,18 @@ checkAddress :: Config -> Map Int (Quality SSL.Address) -> GLS.Address -> [WithS
checkAddress config addresses' address' = catMaybes $ map (compareAddress config address') $ toList addresses'
compareAddress :: Config -> GLS.Address -> (Int, Quality SSL.Address) -> Maybe (WithSSID QualityFloat)
-compareAddress config gls_address (ssid, quality) = if country_score >= 0.75
+compareAddress config gls_address (ssid, quality) = if country_score >= 0.75
then Just $ WithSSID ssid $ liftQuality (\_ -> country_score) quality
- else Nothing
+ else Nothing
where ssl_address = removeQuality quality
total_score = totalFromMaybes [ details_score
, area_score
- , location_score
+ , location_score
, zip_code_score
]
country_score = case SSL.country ssl_address of
- Just c -> if c == GLS.country gls_address then 0.5 * (total_score + 1) else 0
- Nothing -> total_score
+ Just c -> if c == GLS.country gls_address then 0.5 * (total_score + 1) else 0
+ Nothing -> total_score
details_score = case details ssl_address of
Just det -> let
possible_numbers = catMaybes [ Just $ street_number gls_address
@@ -265,7 +272,7 @@ compareAddress config gls_address (ssid, quality) = if country_score >= 0.75
Just zc -> let
ratio = ratioToFloat $ compareText zc 0 [zipcode gls_address]
in
- if ratio >= threshold_ratio config then Just ratio else Nothing
+ if ratio >= threshold_ratio config then Just ratio else Nothing
Nothing -> Nothing
@@ -274,7 +281,7 @@ cleanText text = map (T.foldl (\new_text char -> if char `elem` chars_to_rm
then new_text
else snoc new_text char
) start_text) text
- where chars_to_rm = ".,-" :: String
+ where chars_to_rm = ".,-" :: String
start_text = "" :: Text
permutateText :: [Text] -> [Text]
