From a0d97be8e3bfcdb4b3a530b22e7b0a3a8a551a7f Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Sun, 21 Jul 2024 13:33:25 +0530 Subject: [PATCH 1/7] Added paymentFlow plugin support --- cabal.project | 1 + paymentFlow/.gitignore | 7 + paymentFlow/.juspay/paymentFlowRules.yaml | 60 +++++ paymentFlow/CHANGELOG.md | 5 + paymentFlow/DOC.md | 0 paymentFlow/LICENSE | 20 ++ paymentFlow/README.MD | 24 ++ paymentFlow/paymentFlow.cabal | 98 ++++++++ paymentFlow/src/PaymentFlow/Plugin.hs | 282 ++++++++++++++++++++++ paymentFlow/src/PaymentFlow/Types.hs | 88 +++++++ paymentFlow/test/Main.hs | 67 +++++ paymentFlow/test/Types.hs | 23 ++ paymentFlow/test/Types1.hs | 16 ++ 13 files changed, 691 insertions(+) create mode 100644 paymentFlow/.gitignore create mode 100644 paymentFlow/.juspay/paymentFlowRules.yaml create mode 100644 paymentFlow/CHANGELOG.md create mode 100644 paymentFlow/DOC.md create mode 100644 paymentFlow/LICENSE create mode 100644 paymentFlow/README.MD create mode 100644 paymentFlow/paymentFlow.cabal create mode 100644 paymentFlow/src/PaymentFlow/Plugin.hs create mode 100644 paymentFlow/src/PaymentFlow/Types.hs create mode 100644 paymentFlow/test/Main.hs create mode 100644 paymentFlow/test/Types.hs create mode 100644 paymentFlow/test/Types1.hs diff --git a/cabal.project b/cabal.project index ac5aa04..cbc5a75 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,4 @@ packages: ./fdep ./coresyn2chart ./sheriff + ./paymentFlow diff --git a/paymentFlow/.gitignore b/paymentFlow/.gitignore new file mode 100644 index 0000000..8a0ab4f --- /dev/null +++ b/paymentFlow/.gitignore @@ -0,0 +1,7 @@ +dist-* +result +test/dumps +test/out* +cabal.project.local +.juspay/tmp* +.tmp* \ No newline at end of file diff --git a/paymentFlow/.juspay/paymentFlowRules.yaml b/paymentFlow/.juspay/paymentFlowRules.yaml new file mode 100644 index 0000000..630e0f4 --- /dev/null +++ b/paymentFlow/.juspay/paymentFlowRules.yaml @@ -0,0 +1,60 @@ +rules: + - type_name: "MerchantAccount" + blocked_field : "shouldAddSurcharge" + field_access_whitelisted_fns: ["decidePayStartPathbySurchargeAmt", "isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `shouldAddSurcharge` field from `MerchantAccount` type is not allowed." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "showSurchargeBreakupScreen" + field_access_whitelisted_fns: ["getMerchantConfigStatusAndvalueForPaymentFlow", "getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] + field_rule_fixes: "Direct access of `showSurchargeBreakupScreen` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "includeSurchargeAmountForRefund" + field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `includeSurchargeAmountForRefund` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "offerEnabled" + field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `offerEnabled` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccountAuth" + blocked_field : "offerEnabled" + field_access_whitelisted_fns: ["offerEnableCheck"] + field_rule_fixes: "Direct access of `offerEnabled` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "autoRefundConflictTransactions" + field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `autoRefundConflictTransactions` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "autoRefundMultipleChargedTransactions" + field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `autoRefundMultipleChargedTransactions` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "autoRefundConflictThresholdInMins" + field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `autoRefundConflictThresholdInMins` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "enabledInstantRefund" + field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `enabledInstantRefund` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." + whitelisted_line_nos : [] + + - type_name: "MerchantAccount" + blocked_field : "enableExternalRiskCheck" + field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] + field_rule_fixes: "Direct access of `enableExternalRiskCheck` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." + whitelisted_line_nos : [] \ No newline at end of file diff --git a/paymentFlow/CHANGELOG.md b/paymentFlow/CHANGELOG.md new file mode 100644 index 0000000..30beb0c --- /dev/null +++ b/paymentFlow/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for code-checker + +## 0.1.0.0 -- 2024-07-19 + +* First version. Basic rules based compilation error. diff --git a/paymentFlow/DOC.md b/paymentFlow/DOC.md new file mode 100644 index 0000000..e69de29 diff --git a/paymentFlow/LICENSE b/paymentFlow/LICENSE new file mode 100644 index 0000000..189cd23 --- /dev/null +++ b/paymentFlow/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Juspay + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/paymentFlow/README.MD b/paymentFlow/README.MD new file mode 100644 index 0000000..dffe495 --- /dev/null +++ b/paymentFlow/README.MD @@ -0,0 +1,24 @@ + +# Haskell Code Checker Plugin - Sheriff + +## Overview + +This Haskell plugin automatically verifies function calls for rule violations. It scans the source code to identify function calls and evaluates them against predefined rules to detect any violations. Currently, it supports the following rules: + +1. Blocking access to certain `fields` from a specified `type`. +2. Allowing exceptions to the rule for field access from the type based on field_access_whitelisted_fns or whitelisted_line_nos. + +This tool is useful for developers to enforce better coding practices and prevent the use of specific fields from a type in the code. + +## Usage + +Add this to your ghc-options in cabal and mention `paymentFlow` in build-depends + +``` +-fplugin=PaymentFlow.Plugin +``` +Also, we can provide flags to the plugin in as follows: +``` +-fplugin=PaymentFlow.Plugin:{"throwCompilationError":true,"saveToFile":true,"savePath":".juspay/tmp/paymentFlow/","failOnFileNotFound":true} +``` +By default, it throwsCompilationErrors and doesn't log to file. Also, it fails, if indexedKeys file is not found or is invalid \ No newline at end of file diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal new file mode 100644 index 0000000..fd073a7 --- /dev/null +++ b/paymentFlow/paymentFlow.cabal @@ -0,0 +1,98 @@ +cabal-version: 3.0 +name: paymentFlow +version: 0.1.0.0 +synopsis: A plugin to throw compilation errors based on given rules +license: MIT +license-file: LICENSE +author: harshith.ak-juspay +maintainer: harshith.ak@juspay.in +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md + +Flag Dev + Description: Use ghc options to dump ASTs in dev mode + Default: False + Manual: True + +common common-options + build-depends: base +-- ^>=4.14.3.0 + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + + default-language: Haskell2010 + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + +library + import: common-options + exposed-modules: + PaymentFlow.Plugin + PaymentFlow.Types + other-modules: + build-depends: + bytestring + , containers + , filepath + , ghc + -- ^>= 8.10.7 + , ghc-exactprint + , unordered-containers + , uniplate >= 1.6 && < 1.7 + , references + , classyplate + , aeson + , directory + , extra + , yaml + , text + , aeson-pretty + hs-source-dirs: src + default-language: Haskell2010 + +test-suite paymentFlow-test + import: common-options + + default-language: Haskell2010 + type: exitcode-stdio-1.0 + + hs-source-dirs: test + + main-is: Main.hs + other-modules: + Types + Types1 + + build-depends: + , paymentFlow + , aeson + , text + , containers + , bytestring + , aeson-pretty + , extra + , record-dot-preprocessor + , record-hasfield + , lens >= 4.0 + if flag(Dev) + ghc-options: + -fplugin=PaymentFlow.Plugin + -fplugin-opt=PaymentFlow.Plugin:{"throwCompilationError":true,"saveToFile":true,"savePath":".juspay/tmp/paymentFlow/","rulesConfigPath":".juspay/paymentFlowRules.yaml","failOnFileNotFound":true} + else + ghc-options: + -fplugin=PaymentFlow.Plugin + + default-extensions: DataKinds \ No newline at end of file diff --git a/paymentFlow/src/PaymentFlow/Plugin.hs b/paymentFlow/src/PaymentFlow/Plugin.hs new file mode 100644 index 0000000..36e1742 --- /dev/null +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + +module PaymentFlow.Plugin (plugin) where + +import Control.Reference (biplateRef, (^?), Simple, Traversal) +import Data.Generics.Uniplate.Data (universeBi, childrenBi, contextsBi, holesBi, children) +import Data.List (nub) +import Data.Yaml +import GHC + ( GRHS (..), + GRHSs (..), + GenLocated (L), + HsValBinds (..), + GhcTc, + HsBindLR (..), + HsConDetails (..), + HsConPatDetails, + HsExpr (..), + HsRecField' (..), + HsRecFields (..), + LGRHS, + MatchGroupTc(..), + HsType(..), + LHsType, + NoGhcTc(..), + HsTyLit(..), + HsWildCardBndrs(..), + LHsExpr, + LHsRecField, + LMatch, + LPat, + Match (..), + MatchGroup (..), + Name, + Pat (..), + PatSynBind (..), + noLoc, noExtField, Module (moduleName), moduleNameString,Id(..),getName,nameSrcSpan,IdP(..),GhcPass + ) +import GHC.Hs.Binds (LHsBindLR) +import HscTypes (ModSummary (..)) +import Plugins (CommandLineOption, Plugin (typeCheckResultAction), defaultPlugin) +import Prelude +import Data.Aeson as A +import Control.Exception (try,SomeException) +import Outputable (showSDocUnsafe, ppr, Outputable(..)) +import Control.Monad (when) +import Data.List +import Data.List.Extra (sortOn) +import Data.Maybe (fromMaybe, listToMaybe) +import System.Directory +import PatSyn +import Avail +import TcEnv +import Data.Bool (bool) +import qualified Outputable as OP +import FastString +import Data.Maybe (catMaybes) +import TcRnMonad (addWarn, addErrAt) +import GHC (OverLitTc(..), HsOverLit(..)) +import CoreUtils (exprType) +import Control.Applicative ((<|>)) +import Type (isFunTy, funResultTy, splitAppTys, dropForAlls) +import TyCoRep (Type(..), TyLit (..)) +import qualified Data.ByteString.Lazy.Char8 as Char8 +import ConLike (conLikeWrapId_maybe) +import GhcPlugins hiding (purePlugin, (<>)) +import TcRnTypes +import Bag (bagToList) +import TcEvidence +import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts, defaultRule) +import Data.Foldable (foldl') + +logWarnInfo :: Bool +logWarnInfo = True + +mkInvalidYamlFileErr :: String -> OP.SDoc +mkInvalidYamlFileErr err = OP.text err + +parseYAMLFile :: (FromJSON a) => FilePath -> IO (Either ParseException a) +parseYAMLFile file = decodeFileEither file + +plugin :: Plugin +plugin = defaultPlugin { + typeCheckResultAction = paymentFlow + , pluginRecompile = purePlugin + } + +purePlugin :: [CommandLineOption] -> IO PluginRecompile +purePlugin _ = return NoForceRecompile + +paymentFlow :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv +paymentFlow opts modSummary tcEnv = do + let pluginOpts = case opts of + [] -> defaultPluginOpts + (x : _) -> + fromMaybe defaultPluginOpts $ A.decode (Char8.pack x) + moduleNm = moduleNameString $ moduleName $ ms_mod modSummary + paymentFlowRulesConfigPath = rulesConfigPath pluginOpts + parsedPaymentFlowRules <- liftIO $ parseYAMLFile paymentFlowRulesConfigPath + ruleList <- case parsedPaymentFlowRules of + Left err -> do + when logWarnInfo $ addWarn NoReason (mkInvalidYamlFileErr (show err)) + pure defaultRule + Right (rule :: PFRules) -> pure (nub $ defaultRule <> (rules rule)) + let binds = tcg_binds tcEnv + if ("Types" `isSuffixOf` moduleNm || "Types" `isPrefixOf` moduleNm || "Types" `isInfixOf` moduleNm ) + then pure () + else do + errors <- concat <$> mapM (checkBind ruleList) (bagToList binds) + let sortedErrors = sortOn srcSpan errors + groupedErrors = groupBy (\a b -> srcSpan a == srcSpan b) sortedErrors + childFnFilterLogic srcGrpErrArr = do + let srcSpn = maybe Nothing (\value -> Just $ srcSpan value) (listToMaybe srcGrpErrArr) + srcSpanLine = case srcSpn of + (Just (RealSrcSpan s)) -> srcSpanStartLine s + _ -> 0 + + let shouldThroughError = (any (\(VoilationRuleResult{..}) -> do + let whitelistedRules = field_access_whitelisted_fns rule + fnName `elem` whitelistedRules || coreFnName `elem` whitelistedRules) srcGrpErrArr) || (any (\result -> srcSpanLine `elem` (whitelisted_line_nos (rule result))) srcGrpErrArr) + if shouldThroughError + then Nothing + else listToMaybe srcGrpErrArr + filteredErrors = (\srcGrpErrArr -> childFnFilterLogic srcGrpErrArr) <$> groupedErrors + mapM_ (\ (VoilationRuleResult {..}) -> addErrAt srcSpan $ OP.text $ field_rule_fixes rule ) (catMaybes filteredErrors) + return tcEnv + +checkBind :: [Rule] -> LHsBindLR GhcTc GhcTc -> TcM [VoilationRuleResult] +checkBind rule (L _ ap@(FunBind _ id matches _ _)) = do + let funMatches = unLoc $ mg_alts matches + concat <$> mapM (checkMatch rule (showS id)) funMatches +checkBind rule (L _ ap@(AbsBinds {abs_binds = binds})) = + concat <$> (mapM (checkBind rule) $ bagToList binds) +checkBind _ _ = pure [] + +checkMatch :: [Rule] -> String -> LMatch GhcTc (LHsExpr GhcTc) -> TcM [VoilationRuleResult] +checkMatch rule coreFn (L _ (Match _ _ _ grhss)) = do + let whereBinds = (grhssLocalBinds grhss) ^? biplateRef :: [LHsExpr GhcTc] + nonWhereBinds = (grhssGRHSs grhss) ^? biplateRef :: [LHsExpr GhcTc] + loopOverExprInArgsPerFnName (nonWhereBinds <> whereBinds) rule coreFn +checkMatch _ _ _ = pure [] + +loopOverExprInArgsPerFnName :: [LHsExpr GhcTc] -> [Rule] -> String -> TcM [VoilationRuleResult] +loopOverExprInArgsPerFnName exprs rules coreFn = do + liftIO $ print "EXPRS_BEFORE_FN_ARG_SPLIT" + liftIO $ print $ showS exprs + let fnArgTuple = catMaybes (getFnNameWithAllArgs <$> exprs) + liftIO $ print "EXPRS_AFTER_FN_ARG_SPLIT" + liftIO $ print $ showS fnArgTuple + nub <$> concat <$> mapM (lookOverExpr rules coreFn) fnArgTuple +loopOverExprInArgsPerFnName _ _ _ = pure [] + +lookOverExpr :: [Rule] -> String -> (Located Var, [LHsExpr GhcTc]) -> TcM [VoilationRuleResult] +lookOverExpr rules funId (fnName, args) = do + let updatedArgs = args ^? biplateRef :: [LHsExpr GhcTc] + tupleResponse <- catMaybes <$> sequence (checkExpr' rules <$> updatedArgs) + pure $ (\(x, y) -> VoilationRuleResult { fnName = getVarName fnName, srcSpan = x, rule = y, coreFnName = funId }) <$> tupleResponse + +getVarName :: Located Var -> String +getVarName var = (getOccString . varName . unLoc) var + +checkExpr' :: [Rule]-> LHsExpr GhcTc -> TcM (Maybe (SrcSpan, Rule)) +checkExpr' rules expr = do + case expr of + L _ (HsPar _ exp) -> checkExpr' rules exp + L loc1 (HsVar _ (L _ var)) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc1, rule) + + L loc1 (HsApp _ (L _ (HsVar _ (L _ var))) _) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc1, rule) + + L loc12 (OpApp _ (L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (HsWrap _ _ (HsVar _ (L _ var)))))) _ _) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc1, rule) + + L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (HsWrap _ _ (HsVar _ (L _ var))))) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc1, rule) + + L loc1 (HsApp _ (L loc2 (HsAppType _ (L _ (HsWrap _ (WpCompose (WpCompose (WpCompose (WpEvApp (EvExpr _hasFld)) (WpCompose (WpTyApp _fldType) (WpTyApp tableType))) (WpTyApp (LitTy (StrTyLit fastString)))) (WpTyApp _)) (HsVar _ opr))) _)) _) -> do + let tblName' = case tableType of + AppTy ty1 _ -> showS ty1 + TyConApp ty1 _ -> showS ty1 + ty -> showS ty + filteredRule = filter (\rule -> (type_name rule) == tblName' && fastString == (mkFastString $ blocked_field rule)) rules + case listToMaybe filteredRule of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc2, rule) + + _ -> pure Nothing + +showS :: (Outputable a) => a -> String +showS = showSDocUnsafe . ppr + +verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType :: Var -> Var -> [Rule] -> [Rule] +verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules = + let name = showS $ varName var + vType = varType leftVar + arrTypeCon = getTypeConFromType vType + updatedName = if "_" `isPrefixOf` name + then fromMaybe name (stripPrefix "_" name) + else name + in filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + + where + getTypeConFromType vType = + case splitFunTy_maybe vType of + Just (tyCon, _) -> [showS tyCon] + Nothing -> + case vType of + (TyConApp typ tys) -> + if null tys + then [showS typ] + else + (\var -> do + case tyConAppTyCon_maybe var of + Just tyCon -> showS tyCon + Nothing -> "NA" + ) <$> tys + _ -> [] + +verifyAndGetRuleVoilatedFnInfoWithRightExprAsType :: Var -> [Rule] -> [Rule] +verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules = + let name = showS $ varName var + vType = varType var + arrTypeCon = getTypeConFromType vType + updatedName = if "_" `isPrefixOf` name + then fromMaybe name (stripPrefix "_" name) + else name + in filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + + where + getTypeConFromType vType = + case splitFunTy_maybe vType of + Just (tyCon, _) -> [showS tyCon] + Nothing -> + case vType of + (TyConApp _ tys) -> + (\localVar -> do + case tyConAppTyCon_maybe localVar of + Just tyCon -> showS tyCon + Nothing -> "NA" + ) <$> tys + _ -> [] + +getFnNameWithAllArgs :: LHsExpr GhcTc -> Maybe (Located Var, [LHsExpr GhcTc]) +getFnNameWithAllArgs (L _ (HsVar _ v)) = Just (v, []) +getFnNameWithAllArgs (L _ (HsConLikeOut _ cl)) = (\clId -> (noLoc clId, [])) <$> conLikeWrapId_maybe cl +getFnNameWithAllArgs (L _ (HsAppType _ expr _)) = getFnNameWithAllArgs expr +getFnNameWithAllArgs (L _ (HsApp _ (L _ (HsVar _ v)) funr)) = Just (v, [funr]) +getFnNameWithAllArgs (L _ (HsApp _ funl funr)) = do + let res = getFnNameWithAllArgs funl + case res of + Nothing -> Nothing + Just (fnName, ls) -> Just (fnName, ls ++ [funr]) +getFnNameWithAllArgs (L loc (OpApp _ funl op funr)) = do + case op of + (L _ (HsVar _ v)) -> Just (v, [funl,funr]) + (L _ (HsWrap _ _ (HsVar _ var))) -> Just (var, [funl,funr]) + _ -> Nothing +getFnNameWithAllArgs (L loc ap@(HsWrap _ _ expr)) = getFnNameWithAllArgs (L loc expr) +getFnNameWithAllArgs (L _ (HsCase _ funl exprLStmt)) = do + let res = getFnNameWithAllArgs funl + case res of + Nothing -> Nothing + Just (fnName, ls) -> do + let exprs = exprLStmt ^? biplateRef :: [LHsExpr GhcTc] + Just (fnName, ls <> exprs) +getFnNameWithAllArgs _ = Nothing \ No newline at end of file diff --git a/paymentFlow/src/PaymentFlow/Types.hs b/paymentFlow/src/PaymentFlow/Types.hs new file mode 100644 index 0000000..a2e8199 --- /dev/null +++ b/paymentFlow/src/PaymentFlow/Types.hs @@ -0,0 +1,88 @@ +module PaymentFlow.Types where + +import Data.Aeson +-- import SrcLoc +import GHC (SrcSpan) + +data PluginOpts = PluginOpts { + saveToFile :: Bool, + throwCompilationError :: Bool, + failOnFileNotFound :: Bool, + savePath :: String, + rulesConfigPath :: String + } deriving (Show, Eq) + +defaultPluginOpts :: PluginOpts +defaultPluginOpts = + PluginOpts { + saveToFile = False, + throwCompilationError = True, + failOnFileNotFound = True, + savePath = ".juspay/tmp/paymentFlows/", + rulesConfigPath = ".juspay/paymentFlowRules.yaml" + } + +instance FromJSON PluginOpts where + parseJSON = withObject "PluginOpts" $ \o -> do + saveToFile <- o .:? "saveToFile" .!= (saveToFile defaultPluginOpts) + failOnFileNotFound <- o .:? "failOnFileNotFound" .!= (failOnFileNotFound defaultPluginOpts) + throwCompilationError <- o .:? "throwCompilationError" .!= (throwCompilationError defaultPluginOpts) + savePath <- o .:? "savePath" .!= (savePath defaultPluginOpts) + rulesConfigPath <- o .:? "rulesConfigPath" .!= (rulesConfigPath defaultPluginOpts) + return PluginOpts { saveToFile = saveToFile, throwCompilationError = throwCompilationError,savePath = savePath, rulesConfigPath = rulesConfigPath, failOnFileNotFound = failOnFileNotFound } + +type Suggestion = String + +data Rule = + Rule + { type_name :: String + , field_access_whitelisted_fns :: [String] + , blocked_field :: String + , field_rule_fixes :: Suggestion + , whitelisted_line_nos :: [Int] + } deriving (Show, Eq) + +instance FromJSON Rule where + parseJSON = withObject "Rule" $ \o -> do + type_name <- o .: "type_name" + field_access_whitelisted_fns <- o .: "field_access_whitelisted_fns" + blocked_field <- o .: "blocked_field" + field_rule_fixes <- o .: "field_rule_fixes" + whitelisted_line_nos <- o .: "whitelisted_line_nos" + return Rule + { type_name = type_name + , field_access_whitelisted_fns = field_access_whitelisted_fns + , blocked_field = blocked_field + , field_rule_fixes = field_rule_fixes + , whitelisted_line_nos = whitelisted_line_nos + } + +data PFRules = PFRules + { rules :: [Rule] + } deriving (Show, Eq) + +instance FromJSON PFRules where + parseJSON = withObject "PFRules" $ \o -> do + rules <- o .: "rules" + return PFRules { rules = rules } + +data VoilationRuleResult = VoilationRuleResult + { fnName :: String + , srcSpan :: SrcSpan + , rule :: Rule + , coreFnName :: String + } deriving (Show, Eq) + +defaultRule :: [Rule] +defaultRule = + [ Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "shouldAddSurcharge" "Direct access of `shouldAddSurcharge` from `MerchantAccount` type is not allowed." [] + , Rule "MerchantAccount" ["getMerchantConfigStatusAndvalueForPaymentFlow", "getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "showSurchargeBreakupScreen" "Direct access of `showSurchargeBreakupScreen` from `MerchantAccount` type is not allowed." [] + , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "includeSurchargeAmountForRefund" "Direct access of `includeSurchargeAmountForRefund` from `MerchantAccount` type is not allowed." [] + , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "offerEnabled" "Direct access of `offerEnabled` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] + , Rule "MerchantAccountAuth" ["offerEnableCheck"] "offerEnabled" "Direct access of `offerEnabled` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] + , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundConflictTransactions" "Direct access of `autoRefundConflictTransactions` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] + , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundMultipleChargedTransactions" "Direct access of `autoRefundMultipleChargedTransactions` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] + , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundConflictThresholdInMins" "Direct access of `autoRefundConflictThresholdInMins` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] + , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "enabledInstantRefund" "Direct access of `enabledInstantRefund` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] + , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "enableExternalRiskCheck" "Direct access of `enableExternalRiskCheck` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] + ] diff --git a/paymentFlow/test/Main.hs b/paymentFlow/test/Main.hs new file mode 100644 index 0000000..1f16948 --- /dev/null +++ b/paymentFlow/test/Main.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -ddump-tc-ast #-} +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import Data.Text as T +import Data.Maybe (fromMaybe) +import Control.Applicative ((<|>)) +import Prelude +import Data.Aeson as A +import Types as PT +import Types1 as PT1 +import Control.Lens + +main :: IO () +main = putStrLn "Test suite not yet implemented." + +-- test a = +-- let ans = a ++ "TEST" +-- in "" ++ ans + +decidePayStartPathbySurchargeAmt :: PT.TxnDetail -> Text -> Text -> PT.MerchantAccount -> Text +decidePayStartPathbySurchargeAmt txn defaultStartPayPath payStartPath mAcc = do + -- let surchargeConfigStatusAndValue = getMerchantConfigStatusAndvalueForPaymentFlow (mAcc ^. PT.showSurchargeBreakupScreen) + let surchargeConfigStatusAndValue = getMerchantConfigStatus + -- getMerchantConfigStatusAndvalueForPaymentFlow (getMerchantPIdFromMerchantAccount mAcc) (fromMaybe "" (merchantId mAcc)) (Skip mMCLookupConfig) + shouldShowSurchargePage = case surchargeConfigStatusAndValue of + (PT.PaymentFlowNotEligible, _) -> + -- (mAcc.shouldAddSurcharge ) && (mAcc.showSurchargeBreakupScreen) + -- mAcc.shouldAddSurcharge && mAcc ^. PT.showSurchargeBreakupScreen + mAcc ^. PT.showSurchargeBreakupScreen && mAcc.shouldAddSurcharge + -- (PT.shouldAddSurcharge mAcc) && (PT.showSurchargeBreakupScreen mAcc) + (PT.Disabled, _) -> False + (PT.Enabled, surchargeConfigV) -> + (fromMaybe False $ (surchargeConfigV >>= (\sc -> sc.showSurchargeBreakupScreen)) <|> (Just $ mAcc ^. PT.showSurchargeBreakupScreen)) + -- (fromMaybe False $ (surchargeConfigV >>= (\sc -> PT1.showSurchargeBreakupScreen sc)) <|> (Just $ PT.showSurchargeBreakupScreen mAcc)) + if shouldShowSurchargePage + then payStartPath + else defaultStartPayPath + + where + + getMerchantConfigStatus :: (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) + getMerchantConfigStatus = getMerchantConfigStatusAndvalueForPaymentFlow (mAcc ^. PT.showSurchargeBreakupScreen) + + +-- getMerchantPIdFromMerchantAccount :: PT.MerchantAccount -> Text +-- getMerchantPIdFromMerchantAccount = undefined + +-- mMCLookupConfig :: Bool +-- mMCLookupConfig = undefined + +-- isSurchargeNotZero :: PT.TxnDetail -> Bool +-- isSurchargeNotZero = undefined + +-- getMerchantConfigStatusAndvalueForPaymentFlow :: Text -> Text -> AK -> (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) +-- getMerchantConfigStatusAndvalueForPaymentFlow _ _ _ = (PT.Enabled, Just $ PT1.SurchargeConfig {shouldAddSurchargeToRefund = False, showSurchargeBreakupScreen = Just True}) + +getMerchantConfigStatusAndvalueForPaymentFlow ::Bool -> (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) +getMerchantConfigStatusAndvalueForPaymentFlow _ = (PT.Enabled, Just $ PT1.SurchargeConfig {shouldAddSurchargeToRefund = False, showSurchargeBreakupScreen = Just True}) \ No newline at end of file diff --git a/paymentFlow/test/Types.hs b/paymentFlow/test/Types.hs new file mode 100644 index 0000000..e6fc10e --- /dev/null +++ b/paymentFlow/test/Types.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Types where + +import Data.Aeson +import Data.Text +import Control.Lens + +data TxnDetail = TxnDetail + +data MerchantAccount = MerchantAccount { + merchantId :: Maybe Text, + shouldAddSurcharge :: Bool, + _showSurchargeBreakupScreen :: Bool +} + +data AK = Skip Bool | Force + +data MerchantConfigStatus = PaymentFlowNotEligible | Disabled | Enabled + +makeLenses ''MerchantAccount \ No newline at end of file diff --git a/paymentFlow/test/Types1.hs b/paymentFlow/test/Types1.hs new file mode 100644 index 0000000..e6576c1 --- /dev/null +++ b/paymentFlow/test/Types1.hs @@ -0,0 +1,16 @@ +-- {-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +module Types1 where + +import Data.Aeson +import Control.Lens + +data SurchargeConfig = SurchargeConfig + {shouldAddSurchargeToRefund :: Bool, showSurchargeBreakupScreen :: Maybe Bool} + deriving (Show, Eq) + + From 37682a5ac1f9a711304b48efbf048bf4e9507471 Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Mon, 22 Jul 2024 15:17:36 +0530 Subject: [PATCH 2/7] Removed loglines --- paymentFlow/src/PaymentFlow/Plugin.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/paymentFlow/src/PaymentFlow/Plugin.hs b/paymentFlow/src/PaymentFlow/Plugin.hs index 36e1742..37c0811 100644 --- a/paymentFlow/src/PaymentFlow/Plugin.hs +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -145,11 +145,7 @@ checkMatch _ _ _ = pure [] loopOverExprInArgsPerFnName :: [LHsExpr GhcTc] -> [Rule] -> String -> TcM [VoilationRuleResult] loopOverExprInArgsPerFnName exprs rules coreFn = do - liftIO $ print "EXPRS_BEFORE_FN_ARG_SPLIT" - liftIO $ print $ showS exprs let fnArgTuple = catMaybes (getFnNameWithAllArgs <$> exprs) - liftIO $ print "EXPRS_AFTER_FN_ARG_SPLIT" - liftIO $ print $ showS fnArgTuple nub <$> concat <$> mapM (lookOverExpr rules coreFn) fnArgTuple loopOverExprInArgsPerFnName _ _ _ = pure [] From 0b0296f73d2711d5d6d9e92ad944d1290465198f Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Mon, 22 Jul 2024 16:57:36 +0530 Subject: [PATCH 3/7] gst --- paymentFlow/README.MD | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/paymentFlow/README.MD b/paymentFlow/README.MD index dffe495..3d6eca4 100644 --- a/paymentFlow/README.MD +++ b/paymentFlow/README.MD @@ -21,4 +21,4 @@ Also, we can provide flags to the plugin in as follows: ``` -fplugin=PaymentFlow.Plugin:{"throwCompilationError":true,"saveToFile":true,"savePath":".juspay/tmp/paymentFlow/","failOnFileNotFound":true} ``` -By default, it throwsCompilationErrors and doesn't log to file. Also, it fails, if indexedKeys file is not found or is invalid \ No newline at end of file +By default, it throwsCompilationErrors. \ No newline at end of file From 9c7919ddedc333c25407523f01c0210b132689c1 Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Mon, 22 Jul 2024 16:57:59 +0530 Subject: [PATCH 4/7] Reverted comments lines --- paymentFlow/paymentFlow.cabal | 6 ++---- paymentFlow/src/PaymentFlow/Plugin.hs | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal index fd073a7..bb6ac12 100644 --- a/paymentFlow/paymentFlow.cabal +++ b/paymentFlow/paymentFlow.cabal @@ -16,8 +16,7 @@ Flag Dev Manual: True common common-options - build-depends: base --- ^>=4.14.3.0 + build-depends: base ^>=4.14.3.0 ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -47,8 +46,7 @@ library bytestring , containers , filepath - , ghc - -- ^>= 8.10.7 + , ghc ^>= 8.10.7 , ghc-exactprint , unordered-containers , uniplate >= 1.6 && < 1.7 diff --git a/paymentFlow/src/PaymentFlow/Plugin.hs b/paymentFlow/src/PaymentFlow/Plugin.hs index 37c0811..3541f2d 100644 --- a/paymentFlow/src/PaymentFlow/Plugin.hs +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -118,7 +118,7 @@ paymentFlow opts modSummary tcEnv = do (Just (RealSrcSpan s)) -> srcSpanStartLine s _ -> 0 - let shouldThroughError = (any (\(VoilationRuleResult{..}) -> do + shouldThroughError = (any (\(VoilationRuleResult{..}) -> do let whitelistedRules = field_access_whitelisted_fns rule fnName `elem` whitelistedRules || coreFnName `elem` whitelistedRules) srcGrpErrArr) || (any (\result -> srcSpanLine `elem` (whitelisted_line_nos (rule result))) srcGrpErrArr) if shouldThroughError From a61f153a4135219779be157864da0fa3c85f2ca5 Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Sun, 4 Aug 2024 23:20:17 +0530 Subject: [PATCH 5/7] Added ghc-9 compiler support --- flake.lock | 566 +++++++++++++++++++++- flake.nix | 109 ++++- paymentFlow/.juspay/paymentFlowRules.yaml | 2 +- paymentFlow/DOC.md | 7 + paymentFlow/README.MD | 2 +- paymentFlow/paymentFlow.cabal | 10 +- paymentFlow/src/PaymentFlow/Patterns.hs | 30 ++ paymentFlow/src/PaymentFlow/Plugin.hs | 328 ++++++++----- paymentFlow/src/PaymentFlow/Types.hs | 10 +- paymentFlow/test/Main.hs | 25 +- paymentFlow/test/Types.hs | 1 + 11 files changed, 906 insertions(+), 184 deletions(-) create mode 100644 paymentFlow/src/PaymentFlow/Patterns.hs diff --git a/flake.lock b/flake.lock index 2400bb8..b835382 100644 --- a/flake.lock +++ b/flake.lock @@ -1,19 +1,41 @@ { "nodes": { - "classyplate": { + "beam": { "flake": false, "locked": { - "lastModified": 1678370822, - "narHash": "sha256-8AJ/55ShKCe49MEcyMqzJ3ADjs5dvtuTIhuTTq2q5nQ=", - "owner": "Chaitanya-nair", + "lastModified": 1696055201, + "narHash": "sha256-BIq3ZjZQWQ0w3zWA19zGBggiVVfnOzR5d4b7De0oVZY=", + "owner": "juspay", + "repo": "beam", + "rev": "c4f86057db76640245c3d1fde040176c53e9b9a3", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "beam", + "rev": "c4f86057db76640245c3d1fde040176c53e9b9a3", + "type": "github" + } + }, + "classyplate": { + "inputs": { + "flake-parts": "flake-parts", + "haskell-flake": "haskell-flake", + "nixpkgs": "nixpkgs", + "systems": "systems" + }, + "locked": { + "lastModified": 1721385699, + "narHash": "sha256-Gof2hSQSX581LA8GGnHGjXWu5F899Cot+Id1SYxlUMY=", + "owner": "eswar2001", "repo": "classyplate", - "rev": "46f5e0e7073e1d047f70473bf3c75366a613bfeb", + "rev": "a360f56820df6ca5284091f318bcddcd3e065243", "type": "github" }, "original": { - "owner": "Chaitanya-nair", + "owner": "eswar2001", "repo": "classyplate", - "rev": "46f5e0e7073e1d047f70473bf3c75366a613bfeb", + "rev": "a360f56820df6ca5284091f318bcddcd3e065243", "type": "github" } }, @@ -21,6 +43,24 @@ "inputs": { "nixpkgs-lib": "nixpkgs-lib" }, + "locked": { + "lastModified": 1719994518, + "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_2": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_2" + }, "locked": { "lastModified": 1717285511, "narHash": "sha256-iKzJcpdXih14qYVcZ9QC9XuZYnPc6T8YImb6dX166kw=", @@ -35,9 +75,9 @@ "type": "github" } }, - "flake-parts_2": { + "flake-parts_3": { "inputs": { - "nixpkgs-lib": "nixpkgs-lib_2" + "nixpkgs-lib": "nixpkgs-lib_3" }, "locked": { "lastModified": 1685662779, @@ -53,7 +93,235 @@ "type": "github" } }, + "flake-parts_4": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_4" + }, + "locked": { + "lastModified": 1719994518, + "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_5": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_5" + }, + "locked": { + "lastModified": 1719994518, + "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-parts_6": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib_6" + }, + "locked": { + "lastModified": 1685662779, + "narHash": "sha256-cKDDciXGpMEjP1n6HlzKinN0H+oLmNpgeCTzYnsA2po=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "71fb97f0d875fd4de4994dfb849f2c75e17eb6c3", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "ghc-hasfield-plugin": { + "inputs": { + "flake-parts": "flake-parts_5", + "haskell-flake": "haskell-flake_4", + "nixpkgs": "nixpkgs_3", + "systems": "systems_2" + }, + "locked": { + "lastModified": 1721371073, + "narHash": "sha256-1xTFZRE/vAHV/mLMW5rNyZH1SkkbyFqDxXZvw7JwOHo=", + "owner": "eswar2001", + "repo": "ghc-hasfield-plugin", + "rev": "c932ebc0d7e824129bb70c8a078f3c68feed85c9", + "type": "github" + }, + "original": { + "owner": "eswar2001", + "repo": "ghc-hasfield-plugin", + "rev": "c932ebc0d7e824129bb70c8a078f3c68feed85c9", + "type": "github" + } + }, + "ghc8-beam": { + "flake": false, + "locked": { + "lastModified": 1689929344, + "narHash": "sha256-uE2/Hq8u9+BjABrM9m6qV+H/88aGnRRzhsE0k8QKSL0=", + "owner": "juspay", + "repo": "beam", + "rev": "e50e6dc6a5a83c4c0c50183416fad33084c81d9e", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "beam", + "rev": "e50e6dc6a5a83c4c0c50183416fad33084c81d9e", + "type": "github" + } + }, + "ghc8-classyplate": { + "flake": false, + "locked": { + "lastModified": 1678370822, + "narHash": "sha256-8AJ/55ShKCe49MEcyMqzJ3ADjs5dvtuTIhuTTq2q5nQ=", + "owner": "Chaitanya-nair", + "repo": "classyplate", + "rev": "46f5e0e7073e1d047f70473bf3c75366a613bfeb", + "type": "github" + }, + "original": { + "owner": "Chaitanya-nair", + "repo": "classyplate", + "rev": "46f5e0e7073e1d047f70473bf3c75366a613bfeb", + "type": "github" + } + }, + "ghc8-ghc-hasfield-plugin": { + "flake": false, + "locked": { + "lastModified": 1658487566, + "narHash": "sha256-pZ6kFNfRtBWWqJ3zZSJhZQz7hcdgTdpkqUbzRCuRSl8=", + "owner": "juspay", + "repo": "ghc-hasfield-plugin", + "rev": "d82ac5a6c0ad643eebe2b9b32c91f6523d3f30dc", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "ghc-hasfield-plugin", + "rev": "d82ac5a6c0ad643eebe2b9b32c91f6523d3f30dc", + "type": "github" + } + }, + "ghc8-large-records": { + "flake": false, + "locked": { + "lastModified": 1719312727, + "narHash": "sha256-NLs4yiUh4vNf4sqOQUUTCr0Fpld1y6ZyZJNhqSTzAI0=", + "owner": "eswar2001", + "repo": "large-records", + "rev": "e393f4501d76a98b4482b0a5b35d120ae70e5dd3", + "type": "github" + }, + "original": { + "owner": "eswar2001", + "repo": "large-records", + "rev": "e393f4501d76a98b4482b0a5b35d120ae70e5dd3", + "type": "github" + } + }, + "ghc8-nixpkgs": { + "locked": { + "lastModified": 1643795778, + "narHash": "sha256-sBxYgXu+4JTpXPu3c1QGl2a2zzzDJj4VNsVatF1sEIY=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "43e3b6af08f29c4447a6073e3d5b86a4f45dd420", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "43e3b6af08f29c4447a6073e3d5b86a4f45dd420", + "type": "github" + } + }, + "ghc8-record-dot-preprocessor": { + "flake": false, + "locked": { + "lastModified": 1644582826, + "narHash": "sha256-BXprRyjI4ZTG+Orz858xmttiC8O0yuubaaKmeRAL/UY=", + "owner": "ndmitchell", + "repo": "record-dot-preprocessor", + "rev": "99452d27f35ea1ff677be9af570d834e8fab4caf", + "type": "github" + }, + "original": { + "owner": "ndmitchell", + "repo": "record-dot-preprocessor", + "rev": "99452d27f35ea1ff677be9af570d834e8fab4caf", + "type": "github" + } + }, + "ghc8-references": { + "inputs": { + "flake-parts": "flake-parts_3", + "haskell-flake": "haskell-flake_2", + "nixpkgs": "nixpkgs_2" + }, + "locked": { + "lastModified": 1686714318, + "narHash": "sha256-Ogy9S6cF/8WNfpcQ1k65rPjjTfWlH15Jp5JeraYaAQQ=", + "owner": "eswar2001", + "repo": "references", + "rev": "35912f3cc72b67fa63a8d59d634401b79796469e", + "type": "github" + }, + "original": { + "owner": "eswar2001", + "repo": "references", + "rev": "35912f3cc72b67fa63a8d59d634401b79796469e", + "type": "github" + } + }, "haskell-flake": { + "locked": { + "lastModified": 1721530802, + "narHash": "sha256-eUMmQKXjt4WQq+IBscftg/Y9bXWiOYhasfeH5Yb9Psc=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "f8f38ecd259338167cc0c85fd541479297a315af", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "haskell-flake_2": { + "locked": { + "lastModified": 1686160859, + "narHash": "sha256-UE+0TQHyPxF8jhbLEeqvNQAy7B79bBix/rpFrf5nsn0=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "908a59167f78035a123ab71ed77af79bed519771", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "haskell-flake_3": { "locked": { "lastModified": 1719249394, "narHash": "sha256-ytIvs6dq1dD3eicwhmqMyhIDH52DfqhOiCpmJbjBYVI=", @@ -68,7 +336,37 @@ "type": "github" } }, - "haskell-flake_2": { + "haskell-flake_4": { + "locked": { + "lastModified": 1720977934, + "narHash": "sha256-k9kwz2lpUqafRUpuCMgkv4AWtHEoJPCds1ZPRkyW2XE=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "cd449f1c04175efdf5b553302d22916640090066", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "haskell-flake_5": { + "locked": { + "lastModified": 1721530802, + "narHash": "sha256-eUMmQKXjt4WQq+IBscftg/Y9bXWiOYhasfeH5Yb9Psc=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "f8f38ecd259338167cc0c85fd541479297a315af", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "haskell-flake_6": { "locked": { "lastModified": 1686160859, "narHash": "sha256-UE+0TQHyPxF8jhbLEeqvNQAy7B79bBix/rpFrf5nsn0=", @@ -83,23 +381,61 @@ "type": "github" } }, + "large-records": { + "inputs": { + "beam": [ + "beam" + ], + "flake-parts": "flake-parts_4", + "ghc-hasfield-plugin": "ghc-hasfield-plugin", + "haskell-flake": "haskell-flake_5", + "nixpkgs": "nixpkgs_4", + "systems": "systems_3" + }, + "locked": { + "lastModified": 1721562622, + "narHash": "sha256-4XivoIvlVl7UyVCyZneeLIvyKBbRIvDEOEnJBxnZp+c=", + "owner": "eswar2001", + "repo": "large-records", + "rev": "b60bcb312c7d55f1d638aa1a5143696e6586e76d", + "type": "github" + }, + "original": { + "owner": "eswar2001", + "repo": "large-records", + "rev": "b60bcb312c7d55f1d638aa1a5143696e6586e76d", + "type": "github" + } + }, "nixpkgs": { "locked": { - "lastModified": 1643795778, - "narHash": "sha256-sBxYgXu+4JTpXPu3c1QGl2a2zzzDJj4VNsVatF1sEIY=", + "lastModified": 1698266953, + "narHash": "sha256-jf72t7pC8+8h8fUslUYbWTX5rKsRwOzRMX8jJsGqDXA=", "owner": "nixos", "repo": "nixpkgs", - "rev": "43e3b6af08f29c4447a6073e3d5b86a4f45dd420", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", "type": "github" }, "original": { "owner": "nixos", "repo": "nixpkgs", - "rev": "43e3b6af08f29c4447a6073e3d5b86a4f45dd420", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", "type": "github" } }, "nixpkgs-lib": { + "locked": { + "lastModified": 1719876945, + "narHash": "sha256-Fm2rDDs86sHy0/1jxTOKB1118Q0O3Uc7EC0iXvXKpbI=", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + } + }, + "nixpkgs-lib_2": { "locked": { "lastModified": 1717284937, "narHash": "sha256-lIbdfCsf8LMFloheeE6N31+BMIeixqyQWbSr2vk79EQ=", @@ -111,7 +447,49 @@ "url": "https://github.com/NixOS/nixpkgs/archive/eb9ceca17df2ea50a250b6b27f7bf6ab0186f198.tar.gz" } }, - "nixpkgs-lib_2": { + "nixpkgs-lib_3": { + "locked": { + "dir": "lib", + "lastModified": 1685564631, + "narHash": "sha256-8ywr3AkblY4++3lIVxmrWZFzac7+f32ZEhH/A8pNscI=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "4f53efe34b3a8877ac923b9350c874e3dcd5dc0a", + "type": "github" + }, + "original": { + "dir": "lib", + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib_4": { + "locked": { + "lastModified": 1719876945, + "narHash": "sha256-Fm2rDDs86sHy0/1jxTOKB1118Q0O3Uc7EC0iXvXKpbI=", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + } + }, + "nixpkgs-lib_5": { + "locked": { + "lastModified": 1719876945, + "narHash": "sha256-Fm2rDDs86sHy0/1jxTOKB1118Q0O3Uc7EC0iXvXKpbI=", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" + } + }, + "nixpkgs-lib_6": { "locked": { "dir": "lib", "lastModified": 1685564631, @@ -145,35 +523,126 @@ "type": "github" } }, + "nixpkgs_3": { + "locked": { + "lastModified": 1698266953, + "narHash": "sha256-jf72t7pC8+8h8fUslUYbWTX5rKsRwOzRMX8jJsGqDXA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + } + }, + "nixpkgs_4": { + "locked": { + "lastModified": 1698266953, + "narHash": "sha256-jf72t7pC8+8h8fUslUYbWTX5rKsRwOzRMX8jJsGqDXA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + } + }, + "nixpkgs_5": { + "locked": { + "lastModified": 1698266953, + "narHash": "sha256-jf72t7pC8+8h8fUslUYbWTX5rKsRwOzRMX8jJsGqDXA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + } + }, + "nixpkgs_6": { + "locked": { + "lastModified": 1698266953, + "narHash": "sha256-jf72t7pC8+8h8fUslUYbWTX5rKsRwOzRMX8jJsGqDXA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "rev": "75a52265bda7fd25e06e3a67dee3f0354e73243c", + "type": "github" + } + }, "references": { "inputs": { - "flake-parts": "flake-parts_2", - "haskell-flake": "haskell-flake_2", - "nixpkgs": "nixpkgs_2" + "flake-parts": "flake-parts_6", + "haskell-flake": "haskell-flake_6", + "nixpkgs": "nixpkgs_6" }, "locked": { - "lastModified": 1686714318, - "narHash": "sha256-Ogy9S6cF/8WNfpcQ1k65rPjjTfWlH15Jp5JeraYaAQQ=", + "lastModified": 1721735703, + "narHash": "sha256-0F/xsz64sUwKQvKL5yuU+7+QPiyvlQFUb8zZI1ZTbrI=", "owner": "eswar2001", "repo": "references", - "rev": "35912f3cc72b67fa63a8d59d634401b79796469e", + "rev": "120ae7826a7af01a527817952ad0c3f5ef08efd0", "type": "github" }, "original": { "owner": "eswar2001", "repo": "references", - "rev": "35912f3cc72b67fa63a8d59d634401b79796469e", + "rev": "120ae7826a7af01a527817952ad0c3f5ef08efd0", "type": "github" } }, "root": { "inputs": { + "beam": "beam", "classyplate": "classyplate", - "flake-parts": "flake-parts", - "haskell-flake": "haskell-flake", - "nixpkgs": "nixpkgs", + "flake-parts": "flake-parts_2", + "ghc8-beam": "ghc8-beam", + "ghc8-classyplate": "ghc8-classyplate", + "ghc8-ghc-hasfield-plugin": "ghc8-ghc-hasfield-plugin", + "ghc8-large-records": "ghc8-large-records", + "ghc8-nixpkgs": "ghc8-nixpkgs", + "ghc8-record-dot-preprocessor": "ghc8-record-dot-preprocessor", + "ghc8-references": "ghc8-references", + "haskell-flake": "haskell-flake_3", + "large-records": "large-records", + "nixpkgs": "nixpkgs_5", "references": "references", - "systems": "systems" + "streamly": "streamly", + "systems": "systems_4" + } + }, + "streamly": { + "flake": false, + "locked": { + "lastModified": 1701516357, + "narHash": "sha256-Ap7kdurs4NZyMUeMUIF5qU5eHKifO9YmnO5eSEvdtA8=", + "owner": "composewell", + "repo": "streamly", + "rev": "12d85026291d9305f93f573d284d0d35abf40968", + "type": "github" + }, + "original": { + "owner": "composewell", + "repo": "streamly", + "rev": "12d85026291d9305f93f573d284d0d35abf40968", + "type": "github" } }, "systems": { @@ -190,6 +659,51 @@ "repo": "default", "type": "github" } + }, + "systems_2": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_3": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "systems_4": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index d1fdf55..72a7da8 100644 --- a/flake.nix +++ b/flake.nix @@ -1,23 +1,75 @@ { inputs = { - nixpkgs.url = "github:nixos/nixpkgs/43e3b6af08f29c4447a6073e3d5b86a4f45dd420"; systems.url = "github:nix-systems/default"; flake-parts.url = "github:hercules-ci/flake-parts"; haskell-flake.url = "github:srid/haskell-flake"; - classyplate.flake = false; - classyplate.url = "github:Chaitanya-nair/classyplate/46f5e0e7073e1d047f70473bf3c75366a613bfeb"; - references.flake = true; - references.url = "github:eswar2001/references/35912f3cc72b67fa63a8d59d634401b79796469e"; + streamly.url = "github:composewell/streamly/12d85026291d9305f93f573d284d0d35abf40968"; + streamly.flake = false; + + # ghc 9.2.8 packages + nixpkgs.url = "github:nixos/nixpkgs/75a52265bda7fd25e06e3a67dee3f0354e73243c"; + classyplate.url = "github:eswar2001/classyplate/a360f56820df6ca5284091f318bcddcd3e065243"; + references.url = "github:eswar2001/references/120ae7826a7af01a527817952ad0c3f5ef08efd0"; + beam.url = "github:juspay/beam/c4f86057db76640245c3d1fde040176c53e9b9a3"; + beam.flake = false; + large-records.url = "github:eswar2001/large-records/b60bcb312c7d55f1d638aa1a5143696e6586e76d"; + large-records.inputs.beam.follows = "beam"; + + # ghc 8.10.7 packages + ghc8-nixpkgs.url = "github:nixos/nixpkgs/43e3b6af08f29c4447a6073e3d5b86a4f45dd420"; + ghc8-beam.url = "github:juspay/beam/e50e6dc6a5a83c4c0c50183416fad33084c81d9e"; + ghc8-beam.flake = false; + ghc8-classyplate.url = "github:Chaitanya-nair/classyplate/46f5e0e7073e1d047f70473bf3c75366a613bfeb"; + ghc8-classyplate.flake = false; + ghc8-references.url = "github:eswar2001/references/35912f3cc72b67fa63a8d59d634401b79796469e"; + ghc8-references.flake = true; + ghc8-ghc-hasfield-plugin.url = "github:juspay/ghc-hasfield-plugin/d82ac5a6c0ad643eebe2b9b32c91f6523d3f30dc"; + ghc8-ghc-hasfield-plugin.flake = false; + ghc8-large-records.url = "github:eswar2001/large-records/e393f4501d76a98b4482b0a5b35d120ae70e5dd3"; + ghc8-large-records.flake = false; + ghc8-record-dot-preprocessor.url = "github:ndmitchell/record-dot-preprocessor/99452d27f35ea1ff677be9af570d834e8fab4caf"; + ghc8-record-dot-preprocessor.flake = false; }; outputs = inputs@{ self, nixpkgs, flake-parts, ... }: - flake-parts.lib.mkFlake { inherit inputs; } { + flake-parts.lib.mkFlake { inherit inputs; } ({ withSystem, ...}: { systems = import inputs.systems; imports = [ inputs.haskell-flake.flakeModule ]; - perSystem = { self', pkgs, ... }: { - + perSystem = { self', pkgs, system, ... }: { # Typically, you just want a single project named "default". But # multiple projects are also possible, each using different GHC version. + + # GHC 8 support + haskellProjects.ghc8 = { + projectFlakeName = "spider"; + basePackages = inputs.ghc8-nixpkgs.legacyPackages.${system}.haskell.packages.ghc8107; + imports = [ + inputs.ghc8-references.haskellFlakeProjectModules.output + ]; + packages = { + classyplate.source = inputs.ghc8-classyplate; + ghc-hasfield-plugin.source = inputs.ghc8-ghc-hasfield-plugin; + large-records.source = inputs.ghc8-large-records + /large-records; + large-generics.source = inputs.ghc8-large-records + /large-generics; + large-anon.source = inputs.ghc8-large-records + /large-anon; + ghc-tcplugin-api.source = "0.7.1.0"; + typelet.source = inputs.ghc8-large-records + /typelet; + record-dot-preprocessor.source = inputs.ghc8-record-dot-preprocessor; + streamly-core.source = inputs.streamly + /core; + beam-core.source = inputs.ghc8-beam + /beam-core; + }; + settings = { + beam-core.jailbreak = true; + sheriff.check = false; + }; + devShell = { + mkShellArgs = { + name = "ghc8-spider"; + }; + hlsCheck.enable = inputs.ghc8-nixpkgs.legacyPackages.${system}.stdenv.isDarwin; # On darwin, sandbox is disabled, so HLS can use the network. + }; + }; + haskellProjects.default = { # The base package set representing a specific GHC version. # By default, this is pkgs.haskellPackages. @@ -29,13 +81,21 @@ # Note that local packages are automatically included in `packages` # (defined by `defaults.packages` option). # + # defaults.enable = false; + # devShell.tools = hp: with hp; { + # inherit cabal-install; + # inherit hp; + # }; projectFlakeName = "spider"; - basePackages = pkgs.haskell.packages.ghc8107; + # basePackages = pkgs.haskell.packages.ghc8107; + basePackages = pkgs.haskell.packages.ghc92; imports = [ inputs.references.haskellFlakeProjectModules.output + inputs.classyplate.haskellFlakeProjectModules.output + inputs.large-records.haskellFlakeProjectModules.output ]; packages = { - classyplate.source = inputs.classyplate; + streamly-core.source = inputs.streamly + /core; }; settings = { # aeson = { @@ -45,7 +105,11 @@ # haddock = false; # broken = false; # }; - sheriff.check = false; + # primitive-checked = { + # broken = false; + # jailbreak = true; + # }; + sheriff.check = false; }; devShell = { @@ -54,14 +118,29 @@ # Programs you want to make available in the shell. # Default programs can be disabled by setting to 'null' - # tools = hp: { fourmolu = hp.fourmolu; ghcid = null; }; - + # tools = hp: { fourmolu = null; ghcid = null; }; + mkShellArgs = { + name = "spider"; + }; hlsCheck.enable = pkgs.stdenv.isDarwin; # On darwin, sandbox is disabled, so HLS can use the network. }; }; # haskell-flake doesn't set the default package, but you can do it here. packages.default = self'.packages.fdep; + + }; + + flake.haskellFlakeProjectModules = { + # To use ghc 9 version, use + # inputs.spider.haskellFlakeProjectModules.output + + # To use ghc 8 version, use + # inputs.spider.haskellFlakeProjectModules.output-ghc8 + + output-ghc8 = { pkgs, lib, ... }: withSystem pkgs.system ({ config, ... }: + config.haskellProjects."ghc8".defaults.projectModules.output + ); }; - }; -} + }); +} \ No newline at end of file diff --git a/paymentFlow/.juspay/paymentFlowRules.yaml b/paymentFlow/.juspay/paymentFlowRules.yaml index 630e0f4..70f5e25 100644 --- a/paymentFlow/.juspay/paymentFlowRules.yaml +++ b/paymentFlow/.juspay/paymentFlowRules.yaml @@ -2,7 +2,7 @@ rules: - type_name: "MerchantAccount" blocked_field : "shouldAddSurcharge" field_access_whitelisted_fns: ["decidePayStartPathbySurchargeAmt", "isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `shouldAddSurcharge` field from `MerchantAccount` type is not allowed." + field_rule_fixes: "Direct access of `shouldAddSurcharge` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." whitelisted_line_nos : [] - type_name: "MerchantAccount" diff --git a/paymentFlow/DOC.md b/paymentFlow/DOC.md index e69de29..6c75e8a 100644 --- a/paymentFlow/DOC.md +++ b/paymentFlow/DOC.md @@ -0,0 +1,7 @@ +### paymentFlow plugin + +#### What it does? + +`paymentFlow` is a compiler plugin designed to incorporate business logic validation checks during compilation. It performs the following verification: + +***Restrict Access to Specified Type Fields***: This check ensures that deprecated fields within a type are not accessed. The goal is to prevent usage of these restricted fields and to suggest alternative methods for accessing the required information. \ No newline at end of file diff --git a/paymentFlow/README.MD b/paymentFlow/README.MD index 3d6eca4..90609a9 100644 --- a/paymentFlow/README.MD +++ b/paymentFlow/README.MD @@ -3,7 +3,7 @@ ## Overview -This Haskell plugin automatically verifies function calls for rule violations. It scans the source code to identify function calls and evaluates them against predefined rules to detect any violations. Currently, it supports the following rules: +This Haskell plugin automatically verifies `fields` access from a `type` for rule violations. It scans the source code to identify types and evaluates them against predefined rules to detect any violations. Currently, it supports the following rules: 1. Blocking access to certain `fields` from a specified `type`. 2. Allowing exceptions to the rule for field access from the type based on field_access_whitelisted_fns or whitelisted_line_nos. diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal index bb6ac12..41daf73 100644 --- a/paymentFlow/paymentFlow.cabal +++ b/paymentFlow/paymentFlow.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: paymentFlow version: 0.1.0.0 -synopsis: A plugin to throw compilation errors based on given rules +synopsis: A checker plugin to throw compilation errors based on given rules. license: MIT license-file: LICENSE author: harshith.ak-juspay @@ -16,10 +16,11 @@ Flag Dev Manual: True common common-options - build-depends: base ^>=4.14.3.0 + build-depends: base ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wincomplete-patterns -Wcompat -Widentities -Wredundant-constraints @@ -35,6 +36,7 @@ common common-options ScopedTypeVariables StandaloneDeriving TypeApplications + CPP library import: common-options @@ -46,10 +48,10 @@ library bytestring , containers , filepath - , ghc ^>= 8.10.7 + , ghc , ghc-exactprint , unordered-containers - , uniplate >= 1.6 && < 1.7 + , uniplate , references , classyplate , aeson diff --git a/paymentFlow/src/PaymentFlow/Patterns.hs b/paymentFlow/src/PaymentFlow/Patterns.hs new file mode 100644 index 0000000..04faa6a --- /dev/null +++ b/paymentFlow/src/PaymentFlow/Patterns.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE PatternSynonyms #-} + +module PaymentFlow.Patterns where + +import GHC hiding (exprType) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Core.TyCo.Rep +import GHC.Tc.Types.Evidence +import Language.Haskell.Syntax.Expr +#else +import GHC.Hs.Expr +import TcEvidence +import TyCoRep +#endif + +#if __GLASGOW_HASKELL__ >= 900 + +pattern PatHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc +pattern PatHsWrap wrapper expr <- (XExpr (WrapExpr (HsWrap wrapper expr))) + +pattern PatHsExpansion :: HsExpr GhcRn -> HsExpr GhcTc -> HsExpr GhcTc +pattern PatHsExpansion orig expanded <- (XExpr (ExpansionExpr (HsExpanded orig expanded))) + +#else + +pattern PatHsWrap :: HsWrapper -> HsExpr (GhcPass p) -> HsExpr (GhcPass p) +pattern PatHsWrap wrapper expr <- (HsWrap _ wrapper expr) + +#endif \ No newline at end of file diff --git a/paymentFlow/src/PaymentFlow/Plugin.hs b/paymentFlow/src/PaymentFlow/Plugin.hs index 3541f2d..3a511f5 100644 --- a/paymentFlow/src/PaymentFlow/Plugin.hs +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -1,77 +1,56 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Werror=incomplete-patterns #-} module PaymentFlow.Plugin (plugin) where +-- paymentFlow imports +import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts, defaultRule) +import PaymentFlow.Patterns + +-- GHC imports + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Reference (biplateRef, (^?), Simple, Traversal) -import Data.Generics.Uniplate.Data (universeBi, childrenBi, contextsBi, holesBi, children) -import Data.List (nub) -import Data.Yaml -import GHC - ( GRHS (..), - GRHSs (..), - GenLocated (L), - HsValBinds (..), - GhcTc, - HsBindLR (..), - HsConDetails (..), - HsConPatDetails, - HsExpr (..), - HsRecField' (..), - HsRecFields (..), - LGRHS, - MatchGroupTc(..), - HsType(..), - LHsType, - NoGhcTc(..), - HsTyLit(..), - HsWildCardBndrs(..), - LHsExpr, - LHsRecField, - LMatch, - LPat, - Match (..), - MatchGroup (..), - Name, - Pat (..), - PatSynBind (..), - noLoc, noExtField, Module (moduleName), moduleNameString,Id(..),getName,nameSrcSpan,IdP(..),GhcPass - ) -import GHC.Hs.Binds (LHsBindLR) -import HscTypes (ModSummary (..)) -import Plugins (CommandLineOption, Plugin (typeCheckResultAction), defaultPlugin) -import Prelude import Data.Aeson as A -import Control.Exception (try,SomeException) -import Outputable (showSDocUnsafe, ppr, Outputable(..)) -import Control.Monad (when) -import Data.List -import Data.List.Extra (sortOn) -import Data.Maybe (fromMaybe, listToMaybe) -import System.Directory -import PatSyn -import Avail -import TcEnv -import Data.Bool (bool) -import qualified Outputable as OP -import FastString -import Data.Maybe (catMaybes) -import TcRnMonad (addWarn, addErrAt) -import GHC (OverLitTc(..), HsOverLit(..)) -import CoreUtils (exprType) -import Control.Applicative ((<|>)) -import Type (isFunTy, funResultTy, splitAppTys, dropForAlls) -import TyCoRep (Type(..), TyLit (..)) import qualified Data.ByteString.Lazy.Char8 as Char8 -import ConLike (conLikeWrapId_maybe) -import GhcPlugins hiding (purePlugin, (<>)) -import TcRnTypes -import Bag (bagToList) +import Data.Data +import Data.Function (on) +import Data.List (nub, sortBy, groupBy, isInfixOf, isSuffixOf, isPrefixOf, stripPrefix) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Yaml +import GHC hiding (exprType) +import Prelude hiding (id) +import Data.Generics.Uniplate.Data + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Core.ConLike +import GHC.Core.TyCo.Rep +import GHC.Data.Bag +import GHC.HsToCore.Monad +import GHC.HsToCore.Expr +import GHC.Plugins hiding ((<>), getHscEnv, purePlugin) +import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Types.Annotations +import qualified GHC.Utils.Outputable as OP +#else +import Bag +import ConLike +import DsExpr +import DsMonad +import GhcPlugins hiding ((<>), getHscEnv, purePlugin) +import qualified Outputable as OP import TcEvidence -import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts, defaultRule) -import Data.Foldable (foldl') +import TcRnMonad +import TcRnTypes +import TcType +import TyCoRep +#endif logWarnInfo :: Bool logWarnInfo = True @@ -110,14 +89,12 @@ paymentFlow opts modSummary tcEnv = do then pure () else do errors <- concat <$> mapM (checkBind ruleList) (bagToList binds) - let sortedErrors = sortOn srcSpan errors + + let sortedErrors = sortBy (leftmost_smallest `on` srcSpan) errors groupedErrors = groupBy (\a b -> srcSpan a == srcSpan b) sortedErrors childFnFilterLogic srcGrpErrArr = do let srcSpn = maybe Nothing (\value -> Just $ srcSpan value) (listToMaybe srcGrpErrArr) - srcSpanLine = case srcSpn of - (Just (RealSrcSpan s)) -> srcSpanStartLine s - _ -> 0 - + srcSpanLine = getSrcSpanLine srcSpn shouldThroughError = (any (\(VoilationRuleResult{..}) -> do let whitelistedRules = field_access_whitelisted_fns rule fnName `elem` whitelistedRules || coreFnName `elem` whitelistedRules) srcGrpErrArr) || (any (\result -> srcSpanLine `elem` (whitelisted_line_nos (rule result))) srcGrpErrArr) @@ -129,10 +106,10 @@ paymentFlow opts modSummary tcEnv = do return tcEnv checkBind :: [Rule] -> LHsBindLR GhcTc GhcTc -> TcM [VoilationRuleResult] -checkBind rule (L _ ap@(FunBind _ id matches _ _)) = do - let funMatches = unLoc $ mg_alts matches - concat <$> mapM (checkMatch rule (showS id)) funMatches -checkBind rule (L _ ap@(AbsBinds {abs_binds = binds})) = +checkBind rule (L _ (FunBind{..} )) = do + let funMatches = unLoc $ mg_alts fun_matches + concat <$> mapM (checkMatch rule (getVarNameFromIDP $ unLoc fun_id)) funMatches +checkBind rule (L _ (AbsBinds {abs_binds = binds})) = concat <$> (mapM (checkBind rule) $ bagToList binds) checkBind _ _ = pure [] @@ -152,41 +129,58 @@ loopOverExprInArgsPerFnName _ _ _ = pure [] lookOverExpr :: [Rule] -> String -> (Located Var, [LHsExpr GhcTc]) -> TcM [VoilationRuleResult] lookOverExpr rules funId (fnName, args) = do let updatedArgs = args ^? biplateRef :: [LHsExpr GhcTc] - tupleResponse <- catMaybes <$> sequence (checkExpr' rules <$> updatedArgs) + tupleResponse <- catMaybes <$> sequence (checkExpr rules <$> updatedArgs) pure $ (\(x, y) -> VoilationRuleResult { fnName = getVarName fnName, srcSpan = x, rule = y, coreFnName = funId }) <$> tupleResponse -getVarName :: Located Var -> String -getVarName var = (getOccString . varName . unLoc) var - -checkExpr' :: [Rule]-> LHsExpr GhcTc -> TcM (Maybe (SrcSpan, Rule)) -checkExpr' rules expr = do +checkExpr :: [Rule]-> LHsExpr GhcTc -> TcM (Maybe (SrcSpan, Rule)) +checkExpr rules expr = case expr of - L _ (HsPar _ exp) -> checkExpr' rules exp - L loc1 (HsVar _ (L _ var)) -> do - let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules + L _ (HsPar _ exp) -> checkExpr rules exp + +#if __GLASGOW_HASKELL__ >= 900 + L loc (PatHsExpansion orig expanded) -> checkExpr rules (L loc expanded) + + L (SrcSpanAnn _ loc1) (HsApp _ (L _ (HsApp _ op' (L _ (HsVar _ (L _ var))))) (L _ (PatHsWrap _ (HsVar _ (L _ lens))))) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType lens var rules case listToMaybe voilationSatisfiedRules of Nothing -> pure Nothing Just rule -> pure $ Just (loc1, rule) + L _ (HsApp _ (L _ (PatHsWrap _ (HsAppType _ _ (HsWC _ (L (SrcSpanAnn _ loc) (HsTyLit _ (HsStrTy _ fieldName)))) ))) (L _ (HsVar _ (L _ var)))) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithExprAndFieldAsName (showS fieldName) var rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc, rule) + + L (SrcSpanAnn _ loc) (HsApp _ (L _ (HsRecFld _ (Unambiguous name _))) (L _ (HsVar _ (L _ var)))) -> do + let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithExprAndFieldAsName (showS name) var rules + case listToMaybe voilationSatisfiedRules of + Nothing -> pure Nothing + Just rule -> pure $ Just (loc, rule) + + _ -> pure Nothing + +#else + L loc1 (HsApp _ (L _ (HsVar _ (L _ var))) _) -> do let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules case listToMaybe voilationSatisfiedRules of Nothing -> pure Nothing Just rule -> pure $ Just (loc1, rule) - - L loc12 (OpApp _ (L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (HsWrap _ _ (HsVar _ (L _ var)))))) _ _) -> do + + L _ (OpApp _ (L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (PatHsWrap _ (HsVar _ (L _ var)))))) _ _) -> do let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules case listToMaybe voilationSatisfiedRules of Nothing -> pure Nothing Just rule -> pure $ Just (loc1, rule) - L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (HsWrap _ _ (HsVar _ (L _ var))))) -> do + L loc1 (OpApp _ (L _ (HsVar _ (L _ leftVar))) _ (L _ (PatHsWrap _ (HsVar _ (L _ var))))) -> do let voilationSatisfiedRules = verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules case listToMaybe voilationSatisfiedRules of Nothing -> pure Nothing Just rule -> pure $ Just (loc1, rule) - L loc1 (HsApp _ (L loc2 (HsAppType _ (L _ (HsWrap _ (WpCompose (WpCompose (WpCompose (WpEvApp (EvExpr _hasFld)) (WpCompose (WpTyApp _fldType) (WpTyApp tableType))) (WpTyApp (LitTy (StrTyLit fastString)))) (WpTyApp _)) (HsVar _ opr))) _)) _) -> do + L _ (HsApp _ (L loc2 (HsAppType _ (L _ (PatHsWrap (WpCompose (WpCompose (WpCompose (WpEvApp (EvExpr _hasFld)) (WpCompose (WpTyApp _fldType) (WpTyApp tableType))) (WpTyApp (LitTy (StrTyLit fastString)))) (WpTyApp _)) (HsVar _ opr))) _)) _) -> do let tblName' = case tableType of AppTy ty1 _ -> showS ty1 TyConApp ty1 _ -> showS ty1 @@ -198,50 +192,63 @@ checkExpr' rules expr = do _ -> pure Nothing +#endif + showS :: (Outputable a) => a -> String showS = showSDocUnsafe . ppr verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType :: Var -> Var -> [Rule] -> [Rule] -verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules = +verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType var leftVar rules = do let name = showS $ varName var vType = varType leftVar arrTypeCon = getTypeConFromType vType updatedName = if "_" `isPrefixOf` name then fromMaybe name (stripPrefix "_" name) else name - in filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules - where - getTypeConFromType vType = - case splitFunTy_maybe vType of - Just (tyCon, _) -> [showS tyCon] - Nothing -> - case vType of - (TyConApp typ tys) -> - if null tys - then [showS typ] - else - (\var -> do - case tyConAppTyCon_maybe var of - Just tyCon -> showS tyCon - Nothing -> "NA" - ) <$> tys - _ -> [] +verifyAndGetRuleVoilatedFnInfoWithExprAndFieldAsName :: String -> Var -> [Rule] -> [Rule] +verifyAndGetRuleVoilatedFnInfoWithExprAndFieldAsName name leftVar rules = do + let vType = varType leftVar + arrTypeCon = getTypeConFromType vType + updatedName = if "_" `isPrefixOf` name + then fromMaybe name (stripPrefix "_" name) + else name + filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + +getTypeConFromType :: Type -> [String] +getTypeConFromType vType = + case getTyConInStringFormat vType of + Just value -> value + Nothing -> + case vType of + (TyConApp typ tys) -> + if null tys + then [showS typ] + else + (\var -> do + case tyConAppTyCon_maybe var of + Just tyCon -> showS tyCon + Nothing -> "NA" + ) <$> tys + _ -> [] verifyAndGetRuleVoilatedFnInfoWithRightExprAsType :: Var -> [Rule] -> [Rule] -verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules = +verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules = do let name = showS $ varName var vType = varType var arrTypeCon = getTypeConFromType vType updatedName = if "_" `isPrefixOf` name then fromMaybe name (stripPrefix "_" name) else name - in filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules where + + getTypeConFromType :: Type -> [String] getTypeConFromType vType = - case splitFunTy_maybe vType of - Just (tyCon, _) -> [showS tyCon] + case getTyConInStringFormat vType of + Just value -> value Nothing -> case vType of (TyConApp _ tys) -> @@ -252,11 +259,40 @@ verifyAndGetRuleVoilatedFnInfoWithRightExprAsType var rules = ) <$> tys _ -> [] +getTyConInStringFormat :: Type -> Maybe [String] +getTyConInStringFormat vType = +#if __GLASGOW_HASKELL__ >= 900 + case splitFunTy_maybe vType of + Just (_, tyCon, _) -> Just [showS tyCon] + Nothing -> Nothing +#else + case splitFunTy_maybe vType of + Just (tyCon, _) -> Just [showS tyCon] + Nothing -> Nothing +#endif + +conLikeWrapId :: ConLike -> Maybe Var +conLikeWrapId (RealDataCon dc) = Just (dataConWrapId dc) +conLikeWrapId _ = Nothing + +#if __GLASGOW_HASKELL__ >= 900 +noExtFieldOrAnn :: EpAnn a +noExtFieldOrAnn = noAnn + +getLoc2 :: GenLocated (SrcSpanAnn' a) e -> SrcSpan +getLoc2 = getLocA + +noExprLoc :: a -> Located a +noExprLoc = noLoc + +getLocated :: GenLocated (SrcSpanAnn' a) e -> Located e +getLocated ap = L (getLocA ap) (unLoc ap) + getFnNameWithAllArgs :: LHsExpr GhcTc -> Maybe (Located Var, [LHsExpr GhcTc]) -getFnNameWithAllArgs (L _ (HsVar _ v)) = Just (v, []) -getFnNameWithAllArgs (L _ (HsConLikeOut _ cl)) = (\clId -> (noLoc clId, [])) <$> conLikeWrapId_maybe cl +getFnNameWithAllArgs (L _ (HsVar _ v)) = Just (getLocated v, []) +getFnNameWithAllArgs (L _ (HsConLikeOut _ cl)) = (\clId -> (noExprLoc clId, [])) <$> conLikeWrapId cl getFnNameWithAllArgs (L _ (HsAppType _ expr _)) = getFnNameWithAllArgs expr -getFnNameWithAllArgs (L _ (HsApp _ (L _ (HsVar _ v)) funr)) = Just (v, [funr]) +getFnNameWithAllArgs (L _ (HsApp _ (L _ (HsVar _ v)) funr)) = Just (getLocated v, [funr]) getFnNameWithAllArgs (L _ (HsApp _ funl funr)) = do let res = getFnNameWithAllArgs funl case res of @@ -264,10 +300,10 @@ getFnNameWithAllArgs (L _ (HsApp _ funl funr)) = do Just (fnName, ls) -> Just (fnName, ls ++ [funr]) getFnNameWithAllArgs (L loc (OpApp _ funl op funr)) = do case op of - (L _ (HsVar _ v)) -> Just (v, [funl,funr]) - (L _ (HsWrap _ _ (HsVar _ var))) -> Just (var, [funl,funr]) + (L _ (HsVar _ v)) -> Just (getLocated v, [funl,funr]) + (L _ (PatHsWrap _ (HsVar _ var))) -> Just (getLocated var, [funl,funr]) _ -> Nothing -getFnNameWithAllArgs (L loc ap@(HsWrap _ _ expr)) = getFnNameWithAllArgs (L loc expr) +getFnNameWithAllArgs (L loc (PatHsWrap _ expr)) = getFnNameWithAllArgs (L loc expr) getFnNameWithAllArgs (L _ (HsCase _ funl exprLStmt)) = do let res = getFnNameWithAllArgs funl case res of @@ -275,4 +311,66 @@ getFnNameWithAllArgs (L _ (HsCase _ funl exprLStmt)) = do Just (fnName, ls) -> do let exprs = exprLStmt ^? biplateRef :: [LHsExpr GhcTc] Just (fnName, ls <> exprs) -getFnNameWithAllArgs _ = Nothing \ No newline at end of file +getFnNameWithAllArgs (L loc ap@(PatHsExpansion orig expanded)) = + case (orig, expanded) of + ((OpApp _ _ op _), (HsApp _ (L _ (HsApp _ op' funl)) funr)) -> case showS op of + "($)" -> getFnNameWithAllArgs (L loc (HsApp noExtFieldOrAnn funl funr)) + _ -> getFnNameWithAllArgs (L loc expanded) + _ -> getFnNameWithAllArgs (L loc expanded) +getFnNameWithAllArgs _ = Nothing + +#else + +noExtFieldOrAnn :: NoExtField +noExtFieldOrAnn = noExtField + +getLoc2 :: HasSrcSpan a => a -> SrcSpan +getLoc2 = getLoc + +noExprLoc :: (HasSrcSpan a) => SrcSpanLess a -> a +noExprLoc = noLoc + +getLocated :: (HasSrcSpan a) => a -> Located (SrcSpanLess a) +getLocated ap = L (getLoc ap) (unLoc ap) + +getFnNameWithAllArgs :: LHsExpr GhcTc -> Maybe (Located Var, [LHsExpr GhcTc]) +getFnNameWithAllArgs (L _ (HsVar _ v)) = Just (v, []) +getFnNameWithAllArgs (L _ (HsConLikeOut _ cl)) = (\clId -> (noLoc clId, [])) <$> conLikeWrapId_maybe cl +getFnNameWithAllArgs (L _ (HsAppType _ expr _)) = getFnNameWithAllArgs expr +getFnNameWithAllArgs (L _ (HsApp _ (L _ (HsVar _ v)) funr)) = Just (v, [funr]) +getFnNameWithAllArgs (L _ (HsApp _ funl funr)) = do + let res = getFnNameWithAllArgs funl + case res of + Nothing -> Nothing + Just (fnName, ls) -> Just (fnName, ls ++ [funr]) +getFnNameWithAllArgs (L loc (OpApp _ funl op funr)) = + case showS op of + "($)" -> getFnNameWithAllArgs $ (L loc (HsApp noExtFieldOrAnn funl funr)) + _ -> Nothing +getFnNameWithAllArgs (L loc (PatHsWrap _ expr)) = getFnNameWithAllArgs (L loc expr) +getFnNameWithAllArgs (L _ (HsCase _ funl exprLStmt)) = do + let res = getFnNameWithAllArgs funl + case res of + Nothing -> Nothing + Just (fnName, ls) -> do + let exprs = exprLStmt ^? biplateRef :: [LHsExpr GhcTc] + Just (fnName, ls <> exprs) +getFnNameWithAllArgs _ = Nothing + +#endif + +getVarNameFromIDP :: IdP GhcTc -> String +getVarNameFromIDP var = occNameString . occName $ var + +getVarName :: Located Var -> String +getVarName var = (getOccString . varName . unLoc) var + +getSrcSpanLine :: Maybe SrcSpan -> Int +getSrcSpanLine = \case +#if __GLASGOW_HASKELL__ >= 900 + (Just (RealSrcSpan span _)) -> srcSpanStartLine span + _ -> 0 +#else + (Just (RealSrcSpan span)) -> srcSpanStartLine span + _ -> 0 +#endif \ No newline at end of file diff --git a/paymentFlow/src/PaymentFlow/Types.hs b/paymentFlow/src/PaymentFlow/Types.hs index a2e8199..7f93e65 100644 --- a/paymentFlow/src/PaymentFlow/Types.hs +++ b/paymentFlow/src/PaymentFlow/Types.hs @@ -1,8 +1,12 @@ module PaymentFlow.Types where import Data.Aeson --- import SrcLoc -import GHC (SrcSpan) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Types.SrcLoc +#else +import SrcLoc +#endif data PluginOpts = PluginOpts { saveToFile :: Bool, @@ -75,7 +79,7 @@ data VoilationRuleResult = VoilationRuleResult defaultRule :: [Rule] defaultRule = - [ Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "shouldAddSurcharge" "Direct access of `shouldAddSurcharge` from `MerchantAccount` type is not allowed." [] + [ Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "shouldAddSurcharge" "Direct access of `shouldAddSurcharge` from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." [] , Rule "MerchantAccount" ["getMerchantConfigStatusAndvalueForPaymentFlow", "getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "showSurchargeBreakupScreen" "Direct access of `showSurchargeBreakupScreen` from `MerchantAccount` type is not allowed." [] , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "includeSurchargeAmountForRefund" "Direct access of `includeSurchargeAmountForRefund` from `MerchantAccount` type is not allowed." [] , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "offerEnabled" "Direct access of `offerEnabled` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] diff --git a/paymentFlow/test/Main.hs b/paymentFlow/test/Main.hs index 1f16948..5414b2f 100644 --- a/paymentFlow/test/Main.hs +++ b/paymentFlow/test/Main.hs @@ -22,10 +22,6 @@ import Control.Lens main :: IO () main = putStrLn "Test suite not yet implemented." --- test a = --- let ans = a ++ "TEST" --- in "" ++ ans - decidePayStartPathbySurchargeAmt :: PT.TxnDetail -> Text -> Text -> PT.MerchantAccount -> Text decidePayStartPathbySurchargeAmt txn defaultStartPayPath payStartPath mAcc = do -- let surchargeConfigStatusAndValue = getMerchantConfigStatusAndvalueForPaymentFlow (mAcc ^. PT.showSurchargeBreakupScreen) @@ -34,13 +30,14 @@ decidePayStartPathbySurchargeAmt txn defaultStartPayPath payStartPath mAcc = do shouldShowSurchargePage = case surchargeConfigStatusAndValue of (PT.PaymentFlowNotEligible, _) -> -- (mAcc.shouldAddSurcharge ) && (mAcc.showSurchargeBreakupScreen) + -- mAcc.shouldAddSurcharge && mAcc.showSurchargeBreakupScreen -- mAcc.shouldAddSurcharge && mAcc ^. PT.showSurchargeBreakupScreen mAcc ^. PT.showSurchargeBreakupScreen && mAcc.shouldAddSurcharge -- (PT.shouldAddSurcharge mAcc) && (PT.showSurchargeBreakupScreen mAcc) (PT.Disabled, _) -> False (PT.Enabled, surchargeConfigV) -> (fromMaybe False $ (surchargeConfigV >>= (\sc -> sc.showSurchargeBreakupScreen)) <|> (Just $ mAcc ^. PT.showSurchargeBreakupScreen)) - -- (fromMaybe False $ (surchargeConfigV >>= (\sc -> PT1.showSurchargeBreakupScreen sc)) <|> (Just $ PT.showSurchargeBreakupScreen mAcc)) + -- (fromMaybe False $ (surchargeConfigV >>= (\sc -> PT1.showSurchargeBreakupScreen sc)) <|> (Just (PT.showSurchargeBreakupScreen mAcc))) if shouldShowSurchargePage then payStartPath else defaultStartPayPath @@ -48,20 +45,10 @@ decidePayStartPathbySurchargeAmt txn defaultStartPayPath payStartPath mAcc = do where getMerchantConfigStatus :: (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) - getMerchantConfigStatus = getMerchantConfigStatusAndvalueForPaymentFlow (mAcc ^. PT.showSurchargeBreakupScreen) - - --- getMerchantPIdFromMerchantAccount :: PT.MerchantAccount -> Text --- getMerchantPIdFromMerchantAccount = undefined - --- mMCLookupConfig :: Bool --- mMCLookupConfig = undefined - --- isSurchargeNotZero :: PT.TxnDetail -> Bool --- isSurchargeNotZero = undefined - --- getMerchantConfigStatusAndvalueForPaymentFlow :: Text -> Text -> AK -> (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) --- getMerchantConfigStatusAndvalueForPaymentFlow _ _ _ = (PT.Enabled, Just $ PT1.SurchargeConfig {shouldAddSurchargeToRefund = False, showSurchargeBreakupScreen = Just True}) + getMerchantConfigStatus = + -- getMerchantConfigStatusAndvalueForPaymentFlow $ PT.showSurchargeBreakupScreen mAcc + -- getMerchantConfigStatusAndvalueForPaymentFlow (PT.showSurchargeBreakupScreen mAcc) + getMerchantConfigStatusAndvalueForPaymentFlow (mAcc ^. PT.showSurchargeBreakupScreen) getMerchantConfigStatusAndvalueForPaymentFlow ::Bool -> (PT.MerchantConfigStatus, Maybe PT1.SurchargeConfig) getMerchantConfigStatusAndvalueForPaymentFlow _ = (PT.Enabled, Just $ PT1.SurchargeConfig {shouldAddSurchargeToRefund = False, showSurchargeBreakupScreen = Just True}) \ No newline at end of file diff --git a/paymentFlow/test/Types.hs b/paymentFlow/test/Types.hs index e6fc10e..c65baaf 100644 --- a/paymentFlow/test/Types.hs +++ b/paymentFlow/test/Types.hs @@ -13,6 +13,7 @@ data TxnDetail = TxnDetail data MerchantAccount = MerchantAccount { merchantId :: Maybe Text, shouldAddSurcharge :: Bool, + -- showSurchargeBreakupScreen :: Bool _showSurchargeBreakupScreen :: Bool } From 91c8e72eb75afdb2ef425d83bcec3f10abfe4e39 Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Sun, 11 Aug 2024 13:31:26 +0530 Subject: [PATCH 6/7] Review change: Removed default rules and accepting from source repo --- coresyn2chart/coresyn2chart.cabal | 5 +- fdep/fdep.cabal | 5 +- fieldInspector/fieldInspector.cabal | 5 +- paymentFlow/.juspay/paymentFlowRules.yaml | 60 ----------------------- paymentFlow/paymentFlow.cabal | 2 + paymentFlow/src/PaymentFlow/Plugin.hs | 11 ++--- paymentFlow/src/PaymentFlow/Types.hs | 27 +--------- sheriff/sheriff.cabal | 4 +- 8 files changed, 16 insertions(+), 103 deletions(-) delete mode 100644 paymentFlow/.juspay/paymentFlowRules.yaml diff --git a/coresyn2chart/coresyn2chart.cabal b/coresyn2chart/coresyn2chart.cabal index 4b2b1f9..f6a917f 100644 --- a/coresyn2chart/coresyn2chart.cabal +++ b/coresyn2chart/coresyn2chart.cabal @@ -38,13 +38,13 @@ common common-options bytestring , containers , filepath - , ghc ^>= 8.10.7 + , ghc , unordered-containers , aeson , directory , extra , aeson-pretty - , base ^>=4.14.3.0 + , base , text , base64-bytestring , optparse-applicative @@ -55,7 +55,6 @@ common common-options , hasbolt , universum , data-default - , streamly library import: common-options diff --git a/fdep/fdep.cabal b/fdep/fdep.cabal index 4c7f867..f1336e0 100644 --- a/fdep/fdep.cabal +++ b/fdep/fdep.cabal @@ -12,7 +12,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md common common-options - build-depends: base ^>=4.14.3.0 + build-depends: base ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -39,7 +39,7 @@ library bytestring , containers , filepath - , ghc ^>= 8.10.7 + , ghc , ghc-exactprint , unordered-containers , uniplate >= 1.6 && < 1.7 @@ -49,7 +49,6 @@ library , directory , extra , aeson-pretty - , streamly hs-source-dirs: src default-language: Haskell2010 diff --git a/fieldInspector/fieldInspector.cabal b/fieldInspector/fieldInspector.cabal index 0bfa8fe..d0e700f 100644 --- a/fieldInspector/fieldInspector.cabal +++ b/fieldInspector/fieldInspector.cabal @@ -75,13 +75,13 @@ common common-options bytestring , containers , filepath - , ghc ^>= 8.10.7 + , ghc , unordered-containers , aeson , directory , extra , aeson-pretty - , base ^>=4.14.3.0 + , base , text , base64-bytestring , optparse-applicative @@ -92,7 +92,6 @@ common common-options , hasbolt , universum , data-default - , streamly library -- Import common warning flags. diff --git a/paymentFlow/.juspay/paymentFlowRules.yaml b/paymentFlow/.juspay/paymentFlowRules.yaml deleted file mode 100644 index 70f5e25..0000000 --- a/paymentFlow/.juspay/paymentFlowRules.yaml +++ /dev/null @@ -1,60 +0,0 @@ -rules: - - type_name: "MerchantAccount" - blocked_field : "shouldAddSurcharge" - field_access_whitelisted_fns: ["decidePayStartPathbySurchargeAmt", "isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `shouldAddSurcharge` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "showSurchargeBreakupScreen" - field_access_whitelisted_fns: ["getMerchantConfigStatusAndvalueForPaymentFlow", "getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] - field_rule_fixes: "Direct access of `showSurchargeBreakupScreen` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "includeSurchargeAmountForRefund" - field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `includeSurchargeAmountForRefund` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "offerEnabled" - field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `offerEnabled` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccountAuth" - blocked_field : "offerEnabled" - field_access_whitelisted_fns: ["offerEnableCheck"] - field_rule_fixes: "Direct access of `offerEnabled` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "autoRefundConflictTransactions" - field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `autoRefundConflictTransactions` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "autoRefundMultipleChargedTransactions" - field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `autoRefundMultipleChargedTransactions` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "autoRefundConflictThresholdInMins" - field_access_whitelisted_fns: ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `autoRefundConflictThresholdInMins` field from `MerchantAccount` type is not allowed. Use the `getMerchantConfigStatusAndValueForMAPfs` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "enabledInstantRefund" - field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `enabledInstantRefund` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." - whitelisted_line_nos : [] - - - type_name: "MerchantAccount" - blocked_field : "enableExternalRiskCheck" - field_access_whitelisted_fns: ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] - field_rule_fixes: "Direct access of `enableExternalRiskCheck` field from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." - whitelisted_line_nos : [] \ No newline at end of file diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal index 41daf73..56e1c2f 100644 --- a/paymentFlow/paymentFlow.cabal +++ b/paymentFlow/paymentFlow.cabal @@ -60,6 +60,8 @@ library , yaml , text , aeson-pretty + -- , streamly-core + -- , streamly hs-source-dirs: src default-language: Haskell2010 diff --git a/paymentFlow/src/PaymentFlow/Plugin.hs b/paymentFlow/src/PaymentFlow/Plugin.hs index 3a511f5..5b2a692 100644 --- a/paymentFlow/src/PaymentFlow/Plugin.hs +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -5,7 +5,7 @@ module PaymentFlow.Plugin (plugin) where -- paymentFlow imports -import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts, defaultRule) +import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts) import PaymentFlow.Patterns -- GHC imports @@ -52,9 +52,6 @@ import TcType import TyCoRep #endif -logWarnInfo :: Bool -logWarnInfo = True - mkInvalidYamlFileErr :: String -> OP.SDoc mkInvalidYamlFileErr err = OP.text err @@ -81,9 +78,9 @@ paymentFlow opts modSummary tcEnv = do parsedPaymentFlowRules <- liftIO $ parseYAMLFile paymentFlowRulesConfigPath ruleList <- case parsedPaymentFlowRules of Left err -> do - when logWarnInfo $ addWarn NoReason (mkInvalidYamlFileErr (show err)) - pure defaultRule - Right (rule :: PFRules) -> pure (nub $ defaultRule <> (rules rule)) + when (failOnFileNotFound pluginOpts) $ addErr (mkInvalidYamlFileErr (show err)) + pure [] + Right (rule :: PFRules) -> pure (rules rule) let binds = tcg_binds tcEnv if ("Types" `isSuffixOf` moduleNm || "Types" `isPrefixOf` moduleNm || "Types" `isInfixOf` moduleNm ) then pure () diff --git a/paymentFlow/src/PaymentFlow/Types.hs b/paymentFlow/src/PaymentFlow/Types.hs index 7f93e65..b72f6d0 100644 --- a/paymentFlow/src/PaymentFlow/Types.hs +++ b/paymentFlow/src/PaymentFlow/Types.hs @@ -9,31 +9,22 @@ import SrcLoc #endif data PluginOpts = PluginOpts { - saveToFile :: Bool, - throwCompilationError :: Bool, failOnFileNotFound :: Bool, - savePath :: String, rulesConfigPath :: String } deriving (Show, Eq) defaultPluginOpts :: PluginOpts defaultPluginOpts = PluginOpts { - saveToFile = False, - throwCompilationError = True, failOnFileNotFound = True, - savePath = ".juspay/tmp/paymentFlows/", rulesConfigPath = ".juspay/paymentFlowRules.yaml" } instance FromJSON PluginOpts where parseJSON = withObject "PluginOpts" $ \o -> do - saveToFile <- o .:? "saveToFile" .!= (saveToFile defaultPluginOpts) failOnFileNotFound <- o .:? "failOnFileNotFound" .!= (failOnFileNotFound defaultPluginOpts) - throwCompilationError <- o .:? "throwCompilationError" .!= (throwCompilationError defaultPluginOpts) - savePath <- o .:? "savePath" .!= (savePath defaultPluginOpts) rulesConfigPath <- o .:? "rulesConfigPath" .!= (rulesConfigPath defaultPluginOpts) - return PluginOpts { saveToFile = saveToFile, throwCompilationError = throwCompilationError,savePath = savePath, rulesConfigPath = rulesConfigPath, failOnFileNotFound = failOnFileNotFound } + return PluginOpts {rulesConfigPath = rulesConfigPath, failOnFileNotFound = failOnFileNotFound } type Suggestion = String @@ -75,18 +66,4 @@ data VoilationRuleResult = VoilationRuleResult , srcSpan :: SrcSpan , rule :: Rule , coreFnName :: String - } deriving (Show, Eq) - -defaultRule :: [Rule] -defaultRule = - [ Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "getStartPayPath", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "shouldAddSurcharge" "Direct access of `shouldAddSurcharge` from `MerchantAccount` type is not allowed. Use the `isMerchantEnabledForPaymentFlow` function instead." [] - , Rule "MerchantAccount" ["getMerchantConfigStatusAndvalueForPaymentFlow", "getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount", "surchargeConfigStatusAndValue"] "showSurchargeBreakupScreen" "Direct access of `showSurchargeBreakupScreen` from `MerchantAccount` type is not allowed." [] - , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "includeSurchargeAmountForRefund" "Direct access of `includeSurchargeAmountForRefund` from `MerchantAccount` type is not allowed." [] - , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "offerEnabled" "Direct access of `offerEnabled` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] - , Rule "MerchantAccountAuth" ["offerEnableCheck"] "offerEnabled" "Direct access of `offerEnabled` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] - , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundConflictTransactions" "Direct access of `autoRefundConflictTransactions` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] - , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundMultipleChargedTransactions" "Direct access of `autoRefundMultipleChargedTransactions` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] - , Rule "MerchantAccount" ["getMerchantConfigStatusAndValueForMAPfs", "transformECMerchantAccountToEulerMerchantAccount"] "autoRefundConflictThresholdInMins" "Direct access of `autoRefundConflictThresholdInMins` from `MerchantAccount` type is not allowed. Use `getMerchantConfigStatusAndValueForMAPfs` function instead." [] - , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "enabledInstantRefund" "Direct access of `enabledInstantRefund` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] - , Rule "MerchantAccount" ["isMerchantEnabledForPaymentFlow", "transformECMerchantAccountToEulerMerchantAccount"] "enableExternalRiskCheck" "Direct access of `enableExternalRiskCheck` from `MerchantAccount` type is not allowed. Use `isMerchantEnabledForPaymentFlow` function instead." [] - ] + } deriving (Show, Eq) \ No newline at end of file diff --git a/sheriff/sheriff.cabal b/sheriff/sheriff.cabal index fbedc17..f044d66 100644 --- a/sheriff/sheriff.cabal +++ b/sheriff/sheriff.cabal @@ -16,7 +16,7 @@ Flag Dev Manual: True common common-options - build-depends: base ^>=4.14.3.0 + build-depends: base ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -47,7 +47,7 @@ library bytestring , containers , filepath - , ghc ^>= 8.10.7 + , ghc , ghc-exactprint , unordered-containers , uniplate >= 1.6 && < 1.7 From 63f707dd7a6725e39825415383d7293b701737fd Mon Sep 17 00:00:00 2001 From: "harsith a.k" Date: Sun, 11 Aug 2024 13:34:19 +0530 Subject: [PATCH 7/7] Code cleanup --- paymentFlow/paymentFlow.cabal | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal index 56e1c2f..2288267 100644 --- a/paymentFlow/paymentFlow.cabal +++ b/paymentFlow/paymentFlow.cabal @@ -60,8 +60,6 @@ library , yaml , text , aeson-pretty - -- , streamly-core - -- , streamly hs-source-dirs: src default-language: Haskell2010 @@ -92,7 +90,7 @@ test-suite paymentFlow-test if flag(Dev) ghc-options: -fplugin=PaymentFlow.Plugin - -fplugin-opt=PaymentFlow.Plugin:{"throwCompilationError":true,"saveToFile":true,"savePath":".juspay/tmp/paymentFlow/","rulesConfigPath":".juspay/paymentFlowRules.yaml","failOnFileNotFound":true} + -fplugin-opt=PaymentFlow.Plugin:{"rulesConfigPath":".juspay/paymentFlowRules.yaml","failOnFileNotFound":true} else ghc-options: -fplugin=PaymentFlow.Plugin