diff --git a/lib/mobility-core/mobility-core.cabal b/lib/mobility-core/mobility-core.cabal index 7c3cd0c9b..2df7abbe5 100644 --- a/lib/mobility-core/mobility-core.cabal +++ b/lib/mobility-core/mobility-core.cabal @@ -147,6 +147,9 @@ library Kernel.External.Verification.GovtData.Storage.Beam Kernel.External.Verification.GovtData.Storage.Query Kernel.External.Verification.GovtData.Types + Kernel.External.Verification.HyperVerge.Error + Kernel.External.Verification.HyperVerge.Flow + Kernel.External.Verification.HyperVerge.Types Kernel.External.Verification.Idfy.Auth Kernel.External.Verification.Idfy.Client Kernel.External.Verification.Idfy.Config @@ -157,6 +160,7 @@ library Kernel.External.Verification.Idfy.Types.Response Kernel.External.Verification.Idfy.WebhookHandler Kernel.External.Verification.Interface + Kernel.External.Verification.Interface.HyperVerge Kernel.External.Verification.Interface.Idfy Kernel.External.Verification.Interface.InternalScripts Kernel.External.Verification.Interface.Types diff --git a/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Error.hs b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Error.hs new file mode 100644 index 000000000..d0fc5572f --- /dev/null +++ b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Error.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Kernel.External.Verification.HyperVerge.Error where + +import Kernel.Prelude +import Kernel.Types.Error.BaseError +import Kernel.Types.Error.BaseError.HTTPError + +data HyperVergeError + = HyperVergeFaceNotDetected + | HyperVergeCallError Text Text + deriving (Eq, Show, IsBecknAPIError) + +instanceExceptionWithParent 'HTTPException ''HyperVergeError + +instance IsBaseError HyperVergeError where + toMessage = \case + HyperVergeFaceNotDetected -> Just "Face not detected. Please provide a valid image." + HyperVergeCallError code resp -> Just $ "Error Response from Hyperverge. Status Code = " <> code <> " response from HyperVerge is : " <> resp + +instance IsHTTPError HyperVergeError where + toErrorCode = \case + HyperVergeFaceNotDetected -> "FACE_NOT_DETECTED" + HyperVergeCallError _ _ -> "HYPERVERGE_CALL_ERROR" + + toHttpCode = \case + HyperVergeFaceNotDetected -> E422 + HyperVergeCallError _ _ -> E400 -- HVTODO: Check if this error code fits accurately. + +instance IsAPIError HyperVergeError diff --git a/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Flow.hs b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Flow.hs new file mode 100644 index 000000000..03d6d4fdf --- /dev/null +++ b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Flow.hs @@ -0,0 +1,133 @@ +module Kernel.External.Verification.HyperVerge.Flow where + +import qualified Control.Concurrent.MVar as CCMVar +import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BSL +import Kernel.External.Verification.HyperVerge.Error +import Kernel.External.Verification.HyperVerge.Types +import Kernel.Prelude +import Kernel.Tools.Metrics.CoreMetrics (CoreMetrics) +import Kernel.Types.Error (ExternalAPICallError (..)) +import Kernel.Utils.Common hiding (callAPI) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Media (renderHeader) +import Network.HTTP.Types (hContentType) +import Servant.API +import Servant.Client +import Servant.Client.Core +import Servant.Multipart +import Servant.Multipart.Client () +import qualified Servant.Types.SourceT as S + +type FaceValidationAPI = + Header "transactionId" Text + :> Header "appId" Text + :> Header "appKey" Text + :> MultipartForm Tmp HyperVergeSelfieValidationReq + :> "v1" + :> "checkLiveness" + :> Post '[JSON] HyperVergeSelfieValidationRes + +api :: Proxy FaceValidationAPI +api = Proxy + +clientFunction :: Maybe Text -> Maybe Text -> Maybe Text -> (BL.ByteString, HyperVergeSelfieValidationReq) -> ClientM HyperVergeSelfieValidationRes +clientFunction = client api + +callAPI :: Maybe Text -> Maybe Text -> Maybe Text -> HyperVergeSelfieValidationReq -> ClientM HyperVergeSelfieValidationRes +callAPI transactionId appId appKey formData = clientFunction transactionId appId appKey ("xxxxxx", formData) + +callHyperVergeFaceValidationAPI :: + (MonadFlow m, CoreMetrics m) => + BaseUrl -> + Text -> + Text -> + Text -> + HyperVergeSelfieValidationReq -> + m HyperVergeSelfieValidationRes +callHyperVergeFaceValidationAPI url transactionId appId appKey req = do + manager <- liftIO $ Client.newManager tlsManagerSettings + logDebug $ "The request is : " <> (show req) --HVTODO: Remove this + (liftIO $ runClientM (callAPI (Just transactionId) (Just appId) (Just appKey) req) (ClientEnv manager url Nothing modifiedHVMakeClientRequest)) >>= checkHyperVergeError url + +checkHyperVergeError :: (MonadThrow m, Log m) => BaseUrl -> Either ClientError HyperVergeSelfieValidationRes -> m HyperVergeSelfieValidationRes +checkHyperVergeError url resp = do + fromEitherM (hyperVergeError url) resp >>= validateResponseStatus + +hyperVergeError :: BaseUrl -> ClientError -> ExternalAPICallError +hyperVergeError = ExternalAPICallError (Just "HYPERVERGE_API_ERROR") + +validateResponseStatus :: (MonadThrow m, Log m) => HyperVergeSelfieValidationRes -> m HyperVergeSelfieValidationRes +validateResponseStatus response + | response.statusCode == 200 = pure response + | otherwise = throwError $ HyperVergeCallError (show response.statusCode) (show response) + +modifiedHVMakeClientRequest :: BaseUrl -> Request -> Client.Request +modifiedHVMakeClientRequest burl r = + Client.defaultRequest + { Client.method = requestMethod r, + Client.host = fromString $ baseUrlHost burl, + Client.port = baseUrlPort burl, + Client.path = + BSL.toStrict $ + fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r), + Client.queryString = buildQueryString . toList $ requestQueryString r, + Client.requestHeaders = + maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers, + Client.requestBody = body, + Client.secure = isSecure + } + where + -- Content-Type and Accept are specified by requestBody and requestAccept + headers = + filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ + toList $ requestHeaders r + + acceptHdr + | null hs = Nothing + | otherwise = Just ("Accept", renderHeader hs) + where + hs = toList $ requestAccept r + + convertBody bd = case bd of + RequestBodyLBS body' -> Client.RequestBodyLBS body' + RequestBodyBS body' -> Client.RequestBodyBS body' + RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper + where + givesPopper :: (IO BS.ByteString -> IO ()) -> IO () + givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do + ref <- CCMVar.newMVar step0 + + -- Note sure we need locking, but it's feels safer. + let popper :: IO BS.ByteString + popper = CCMVar.modifyMVar ref nextBs + + needsPopper popper + + nextBs S.Stop = return (S.Stop, BS.empty) + nextBs (S.Error err) = fail err + nextBs (S.Skip s) = nextBs s + nextBs (S.Effect ms) = ms >>= nextBs + nextBs (S.Yield lbs s) = case BSL.toChunks lbs of + [] -> nextBs s + (x : xs) + | BS.null x -> nextBs step' + | otherwise -> return (step', x) + where + step' = S.Yield (BSL.fromChunks xs) s + + (body, contentTypeHdr) = case requestBody r of + Nothing -> (Client.RequestBodyBS "", Nothing) + Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ)) + + isSecure = case baseUrlScheme burl of + Http -> False + Https -> True + + -- Query string builder which does not do any encoding + buildQueryString [] = mempty + buildQueryString _ = "" diff --git a/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Types.hs b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Types.hs new file mode 100644 index 000000000..24200704f --- /dev/null +++ b/lib/mobility-core/src/Kernel/External/Verification/HyperVerge/Types.hs @@ -0,0 +1,85 @@ +module Kernel.External.Verification.HyperVerge.Types where + +import Data.Aeson +import qualified Data.Text as T +import Kernel.Prelude hiding (error) +import Servant.Multipart.API (FileData (..), MultipartData (..), Tmp, ToMultipart (..)) + +data HyperVergeConfig = HyperVergeConfig + { url :: BaseUrl, + appId :: Text, + appKey :: Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data HyperVergeSelfieValidationReq = HyperVergeSelfieValidationReq + { image :: FilePath + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +instance ToMultipart Tmp HyperVergeSelfieValidationReq where + toMultipart HyperVergeSelfieValidationReq {..} = + MultipartData + [] + [FileData "image" (T.pack image) "" image] + +data FaceDetails = FaceDetails + { liveFace :: ResultElement, + qualityChecks :: Maybe QualityChecks + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data SummaryDetails = SummaryDetails + { code :: Text, + message :: Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data Summary = Summary + { action :: Text, + details :: [SummaryDetails] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data QualityChecks = QualityChecks + { eyesClosed :: Maybe ResultElement, + maskPresent :: Maybe ResultElement, + multipleFaces :: Maybe ResultElement, + blur :: Maybe ResultElement, + hat :: Maybe ResultElement, + sunglasses :: Maybe ResultElement, + readingGlasses :: Maybe ResultElement, + bright :: Maybe ResultElement, + dull :: Maybe ResultElement, + headTurned :: Maybe ResultElement, + lowQuality :: Maybe ResultElement + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data ResultElement = ResultElement + { confidence :: Text, + value :: Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data ValidationResult = ValidationResult + { error :: Maybe Text, + details :: Maybe FaceDetails, + summary :: Maybe Summary + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data MetaData = MetaData + { requestId :: Text, + transactionId :: Maybe Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data HyperVergeSelfieValidationRes = HyperVergeSelfieValidationRes + { status :: Text, + statusCode :: Int, + result :: Maybe ValidationResult, + metadata :: Maybe MetaData, + error :: Maybe Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) diff --git a/lib/mobility-core/src/Kernel/External/Verification/Interface.hs b/lib/mobility-core/src/Kernel/External/Verification/Interface.hs index fa5ec0060..5e69e3bbc 100644 --- a/lib/mobility-core/src/Kernel/External/Verification/Interface.hs +++ b/lib/mobility-core/src/Kernel/External/Verification/Interface.hs @@ -29,10 +29,10 @@ import qualified Kernel.External.Verification.GovtData.Client as GovtData import Kernel.External.Verification.GovtData.Storage.Beam as BeamGRC import Kernel.External.Verification.GovtData.Types as Reexport import Kernel.External.Verification.Idfy.Config as Reexport +import qualified Kernel.External.Verification.Interface.HyperVerge as HV import qualified Kernel.External.Verification.Interface.Idfy as Idfy import qualified Kernel.External.Verification.Interface.InternalScripts as IS import Kernel.External.Verification.Interface.Types as Reexport -import Kernel.External.Verification.InternalScripts.Types import Kernel.External.Verification.Types as Reexport import Kernel.Tools.Metrics.CoreMetrics.Types import Kernel.Types.Common @@ -50,6 +50,7 @@ verifyDLAsync serviceConfig req = case serviceConfig of IdfyConfig cfg -> Idfy.verifyDLAsync cfg req GovtDataConfig -> throwError $ InternalError "Not Implemented!" FaceVerificationConfig _ -> throwError $ InternalError "Not Implemented!" + HyperVergeConfig _ -> throwError $ InternalError "Not Implemented!" verifyRC :: ( EncFlow m r, @@ -93,6 +94,7 @@ verifyRC' serviceConfig req = case serviceConfig of IdfyConfig cfg -> Idfy.verifyRCAsync cfg req GovtDataConfig -> GovtData.verifyRC req FaceVerificationConfig _ -> throwError $ InternalError "Not Implemented!" + HyperVergeConfig _ -> throwError $ InternalError "Not Implemented!" validateImage :: ( EncFlow m r, @@ -105,6 +107,7 @@ validateImage serviceConfig req = case serviceConfig of IdfyConfig cfg -> Idfy.validateImage cfg req GovtDataConfig -> throwError $ InternalError "Not Implemented!" FaceVerificationConfig _ -> throwError $ InternalError "Not Implemented!" + HyperVergeConfig _ -> throwError $ InternalError "Not Implemented!" validateFaceImage :: ( CoreMetrics m, @@ -117,6 +120,7 @@ validateFaceImage serviceConfig req = case serviceConfig of IdfyConfig _ -> throwError $ InternalError "Not Implemented!" GovtDataConfig -> throwError $ InternalError "Not Implemented!" FaceVerificationConfig cfg -> IS.validateFace cfg req + HyperVergeConfig cfg -> HV.validateFace cfg req extractRCImage :: ( EncFlow m r, @@ -129,6 +133,7 @@ extractRCImage serviceConfig req = case serviceConfig of IdfyConfig cfg -> Idfy.extractRCImage cfg req GovtDataConfig -> throwError $ InternalError "Not Implemented!" FaceVerificationConfig _ -> throwError $ InternalError "Not Implemented!" + HyperVergeConfig _ -> throwError $ InternalError "Not Implemented!" extractDLImage :: ( EncFlow m r, @@ -141,3 +146,4 @@ extractDLImage serviceConfig req = case serviceConfig of IdfyConfig cfg -> Idfy.extractDLImage cfg req GovtDataConfig -> throwError $ InternalError "Not Implemented!" FaceVerificationConfig _ -> throwError $ InternalError "Not Implemented!" + HyperVergeConfig _ -> throwError $ InternalError "Not Implemented!" diff --git a/lib/mobility-core/src/Kernel/External/Verification/Interface/HyperVerge.hs b/lib/mobility-core/src/Kernel/External/Verification/Interface/HyperVerge.hs new file mode 100644 index 000000000..0b1fdbeac --- /dev/null +++ b/lib/mobility-core/src/Kernel/External/Verification/Interface/HyperVerge.hs @@ -0,0 +1,40 @@ +module Kernel.External.Verification.Interface.HyperVerge where + +import qualified Kernel.External.Verification.HyperVerge.Flow as HVFlow +import qualified Kernel.External.Verification.HyperVerge.Types as HyperVerge +import qualified Kernel.External.Verification.Interface.Types as Interface +import qualified Kernel.External.Verification.InternalScripts.Types as InternalScripts +import Kernel.Prelude hiding (error) +import Kernel.Tools.Metrics.CoreMetrics (CoreMetrics) +import Kernel.Types.Common +import Kernel.Utils.Logging (logDebug) + +validateFace :: (CoreMetrics m, MonadFlow m) => HyperVerge.HyperVergeConfig -> Interface.FaceValidationReq -> m Interface.FaceValidationRes +validateFace hvCfg req = do + let url = hvCfg.url + let appId = hvCfg.appId + let appKey = hvCfg.appKey + let transactionId = req.transactionId + let hvReq = makeHyperVergeSelfieValidationReq req + res <- HVFlow.callHyperVergeFaceValidationAPI url transactionId appId appKey hvReq + logDebug $ "HyperVerge Response (before converting into Int. type) is :" <> show res --HVTODO: Remove this + resp <- makeHyperVergeSelfieValidationResp res + logDebug $ "HyperVerge Parsed Response is :" <> show resp --HVTODO: Remove this + return resp + where + makeHyperVergeSelfieValidationReq Interface.FaceValidationReq {..} = HyperVerge.HyperVergeSelfieValidationReq {..} + makeHyperVergeSelfieValidationResp HyperVerge.HyperVergeSelfieValidationRes {..} = do + let (faceType, confidence) = case result of + Nothing -> (InternalScripts.UNKNOWN, Nothing) + Just r -> case r.details of + Nothing -> (InternalScripts.UNKNOWN, Nothing) + Just HyperVerge.FaceDetails {..} -> case liveFace.value of + "yes" -> (InternalScripts.REAL_FACE, Just liveFace.confidence) + "no" -> (InternalScripts.FAKE_FACE, Just liveFace.confidence) + _ -> (InternalScripts.UNKNOWN, Just liveFace.confidence) + return $ + Interface.FaceValidationRes + { score = Nothing, + predictionCost = Nothing, + .. + } diff --git a/lib/mobility-core/src/Kernel/External/Verification/Interface/InternalScripts.hs b/lib/mobility-core/src/Kernel/External/Verification/Interface/InternalScripts.hs index ba7bfe6fe..7e88bec10 100644 --- a/lib/mobility-core/src/Kernel/External/Verification/Interface/InternalScripts.hs +++ b/lib/mobility-core/src/Kernel/External/Verification/Interface/InternalScripts.hs @@ -12,24 +12,33 @@ General Public License along with this program. If not, see . -} -module Kernel.External.Verification.Interface.InternalScripts - ( module Reexport, - validateFace, - ) -where +module Kernel.External.Verification.Interface.InternalScripts where import Control.Monad +import qualified Kernel.External.Verification.Interface.Types as Interface import Kernel.External.Verification.InternalScripts.Error import qualified Kernel.External.Verification.InternalScripts.FaceVerification as FV -import Kernel.External.Verification.InternalScripts.Types as Reexport +import qualified Kernel.External.Verification.InternalScripts.Types as InternalScripts +import Kernel.Prelude import Kernel.Tools.Metrics.CoreMetrics (CoreMetrics) import Kernel.Utils.Common -validateFace :: (CoreMetrics m, MonadFlow m) => FaceVerificationCfg -> FaceValidationReq -> m FaceValidationRes +validateFace :: (CoreMetrics m, MonadFlow m) => InternalScripts.FaceVerificationCfg -> Interface.FaceValidationReq -> m Interface.FaceValidationRes validateFace fvCfg req = do let url = fvCfg.url - res <- FV.validateFace url req + let intScrReq = makeInternalScriptsFaceValidationReq req + res <- FV.validateFace url intScrReq case res.faceType of - UNKNOWN -> throwError PoorImageQuality - FAKE_FACE -> throwError FakeFaceDetected - REAL_FACE -> return res + InternalScripts.UNKNOWN -> throwError PoorImageQuality + InternalScripts.FAKE_FACE -> throwError FakeFaceDetected + InternalScripts.REAL_FACE -> makeInterfaceFaceValidationResp res + where + makeInternalScriptsFaceValidationReq Interface.FaceValidationReq {..} = InternalScripts.FaceValidationReq {..} + makeInterfaceFaceValidationResp InternalScripts.FaceValidationRes {..} = + return $ + Interface.FaceValidationRes + { confidence = Nothing, + score = Just score, + predictionCost = Just predictionCost, + .. + } diff --git a/lib/mobility-core/src/Kernel/External/Verification/Interface/Types.hs b/lib/mobility-core/src/Kernel/External/Verification/Interface/Types.hs index b48d03512..605ec369f 100644 --- a/lib/mobility-core/src/Kernel/External/Verification/Interface/Types.hs +++ b/lib/mobility-core/src/Kernel/External/Verification/Interface/Types.hs @@ -20,13 +20,15 @@ where import Deriving.Aeson import EulerHS.Prelude +import qualified Kernel.External.Verification.HyperVerge.Types as HV import qualified Kernel.External.Verification.Idfy.Config as Idfy import qualified Kernel.External.Verification.Idfy.Types.Response as Idfy +import Kernel.External.Verification.InternalScripts.Types (FaceType) import qualified Kernel.External.Verification.InternalScripts.Types as FV import qualified Kernel.External.Verification.Types as VT import Kernel.Prelude -data VerificationServiceConfig = IdfyConfig Idfy.IdfyCfg | FaceVerificationConfig FV.FaceVerificationCfg | GovtDataConfig +data VerificationServiceConfig = IdfyConfig Idfy.IdfyCfg | FaceVerificationConfig FV.FaceVerificationCfg | GovtDataConfig | HyperVergeConfig HV.HyperVergeConfig deriving stock (Show, Eq, Generic) deriving anyclass (FromJSON, ToJSON) @@ -122,3 +124,19 @@ data ExtractedDL = ExtractedDL type GetTaskReq = Text type GetTaskResp = Idfy.VerificationResponse + +data FaceValidationReq = FaceValidationReq + { file :: Text, + brisqueFeatures :: [Double], + image :: FilePath, + transactionId :: Text + } + deriving (Generic, ToJSON) + +data FaceValidationRes = FaceValidationRes + { faceType :: FaceType, + score :: Maybe Double, + predictionCost :: Maybe Double, + confidence :: Maybe Text + } + deriving (Generic, FromJSON, Show, ToJSON) diff --git a/lib/mobility-core/src/Kernel/External/Verification/Types.hs b/lib/mobility-core/src/Kernel/External/Verification/Types.hs index c2692f0df..a4f374c3d 100644 --- a/lib/mobility-core/src/Kernel/External/Verification/Types.hs +++ b/lib/mobility-core/src/Kernel/External/Verification/Types.hs @@ -25,7 +25,7 @@ import EulerHS.Prelude import Kernel.Beam.Lib.UtilsTH (mkBeamInstancesForEnumAndList) import Kernel.Storage.Esqueleto (derivePersistField) -data VerificationService = Idfy | InternalScripts | GovtData +data VerificationService = Idfy | InternalScripts | GovtData | HyperVerge deriving (Show, Read, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) $(mkBeamInstancesForEnumAndList ''VerificationService)