diff --git a/cabal.project b/cabal.project index 2d76ffa..8e6e2b2 100644 --- a/cabal.project +++ b/cabal.project @@ -3,3 +3,4 @@ packages: ./coresyn2chart ./sheriff ./fieldInspector + ./paymentFlow 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/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/.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/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..6c75e8a --- /dev/null +++ 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/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..90609a9 --- /dev/null +++ b/paymentFlow/README.MD @@ -0,0 +1,24 @@ + +# Haskell Code Checker Plugin - Sheriff + +## Overview + +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. + +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. \ No newline at end of file diff --git a/paymentFlow/paymentFlow.cabal b/paymentFlow/paymentFlow.cabal new file mode 100644 index 0000000..2288267 --- /dev/null +++ b/paymentFlow/paymentFlow.cabal @@ -0,0 +1,98 @@ +cabal-version: 3.0 +name: paymentFlow +version: 0.1.0.0 +synopsis: A checker 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 + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wincomplete-patterns + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + + default-language: Haskell2010 + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + CPP + +library + import: common-options + exposed-modules: + PaymentFlow.Plugin + PaymentFlow.Types + other-modules: + build-depends: + bytestring + , containers + , filepath + , ghc + , ghc-exactprint + , unordered-containers + , uniplate + , 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:{"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/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 new file mode 100644 index 0000000..5b2a692 --- /dev/null +++ b/paymentFlow/src/PaymentFlow/Plugin.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module PaymentFlow.Plugin (plugin) where + +-- paymentFlow imports +import PaymentFlow.Types (VoilationRuleResult(..), PFRules(..), Rule(..), PluginOpts(..), defaultPluginOpts) +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.Aeson as A +import qualified Data.ByteString.Lazy.Char8 as Char8 +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 TcRnMonad +import TcRnTypes +import TcType +import TyCoRep +#endif + +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 (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 () + else do + errors <- concat <$> mapM (checkBind ruleList) (bagToList binds) + + 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 = 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) + 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 _ (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 [] + +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 + let fnArgTuple = catMaybes (getFnNameWithAllArgs <$> exprs) + 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 + +checkExpr :: [Rule]-> LHsExpr GhcTc -> TcM (Maybe (SrcSpan, Rule)) +checkExpr rules expr = + case expr of + 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 _ (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 _ (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 _ (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 + 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 + +#endif + +showS :: (Outputable a) => a -> String +showS = showSDocUnsafe . ppr + +verifyAndGetRuleVoilatedFnInfoWithLeftExprAsType :: Var -> Var -> [Rule] -> [Rule] +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 + filter (\rule -> elem (type_name rule) arrTypeCon && updatedName == blocked_field rule) rules + +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 = do + let name = showS $ varName var + vType = varType var + 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 + + where + + getTypeConFromType :: Type -> [String] + getTypeConFromType vType = + case getTyConInStringFormat vType of + Just value -> value + Nothing -> + case vType of + (TyConApp _ tys) -> + (\localVar -> do + case tyConAppTyCon_maybe localVar of + Just tyCon -> showS tyCon + Nothing -> "NA" + ) <$> 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 (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 (getLocated 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 (getLocated v, [funl,funr]) + (L _ (PatHsWrap _ (HsVar _ var))) -> Just (getLocated var, [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 (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 new file mode 100644 index 0000000..b72f6d0 --- /dev/null +++ b/paymentFlow/src/PaymentFlow/Types.hs @@ -0,0 +1,69 @@ +module PaymentFlow.Types where + +import Data.Aeson + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Types.SrcLoc +#else +import SrcLoc +#endif + +data PluginOpts = PluginOpts { + failOnFileNotFound :: Bool, + rulesConfigPath :: String + } deriving (Show, Eq) + +defaultPluginOpts :: PluginOpts +defaultPluginOpts = + PluginOpts { + failOnFileNotFound = True, + rulesConfigPath = ".juspay/paymentFlowRules.yaml" + } + +instance FromJSON PluginOpts where + parseJSON = withObject "PluginOpts" $ \o -> do + failOnFileNotFound <- o .:? "failOnFileNotFound" .!= (failOnFileNotFound defaultPluginOpts) + rulesConfigPath <- o .:? "rulesConfigPath" .!= (rulesConfigPath defaultPluginOpts) + return PluginOpts {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) \ No newline at end of file diff --git a/paymentFlow/test/Main.hs b/paymentFlow/test/Main.hs new file mode 100644 index 0000000..5414b2f --- /dev/null +++ b/paymentFlow/test/Main.hs @@ -0,0 +1,54 @@ +{-# 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." + +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.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 $ 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 new file mode 100644 index 0000000..c65baaf --- /dev/null +++ b/paymentFlow/test/Types.hs @@ -0,0 +1,24 @@ +{-# 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 + _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) + + 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