|
| 1 | +{-# LANGUAGE ViewPatterns #-} |
| 2 | +{-# LANGUAGE BangPatterns #-} |
| 3 | +{-# LANGUAGE RecordWildCards #-} |
| 4 | +{-# LANGUAGE CPP #-} |
| 5 | +{-# OPTIONS_GHC -Wno-unused-top-binds #-} |
| 6 | +-- | |
| 7 | + |
| 8 | +module Test.Consensus.Cardano.GenCDDLs (withCDDLs) where |
| 9 | + |
| 10 | +import qualified Control.Monad as Monad |
| 11 | +import qualified Data.ByteString as BS |
| 12 | +import qualified Data.ByteString.Lazy as BSL |
| 13 | +import qualified Data.ByteString.Char8 as BS8 |
| 14 | +import Data.Maybe (isNothing) |
| 15 | +import qualified Data.List as L |
| 16 | +import Paths_ouroboros_consensus_cardano |
| 17 | +import qualified System.Directory as D |
| 18 | +import qualified System.Environment as E |
| 19 | +import System.Exit |
| 20 | +import qualified System.FilePath as F |
| 21 | +import qualified System.Process.ByteString.Lazy as P |
| 22 | + |
| 23 | +-- TODO: this is waiting to update to a newer ledger |
| 24 | +--import qualified Test.Cardano.Chain.Binary.Cddl as Byron |
| 25 | +import qualified Test.Cardano.Ledger.Allegra.Binary.Cddl as Allegra |
| 26 | +import qualified Test.Cardano.Ledger.Alonzo.Binary.Cddl as Alonzo |
| 27 | +import qualified Test.Cardano.Ledger.Babbage.Binary.Cddl as Babbage |
| 28 | +import qualified Test.Cardano.Ledger.Conway.Binary.Cddl as Conway |
| 29 | +import qualified Test.Cardano.Ledger.Mary.Binary.Cddl as Mary |
| 30 | +import qualified Test.Cardano.Ledger.Shelley.Binary.Cddl as Shelley |
| 31 | +import System.IO |
| 32 | +import Test.Tasty |
| 33 | +import System.IO.Temp |
| 34 | + |
| 35 | +newtype CDDLSpec = CDDLSpec { cddlSpec :: BS.ByteString } deriving Show |
| 36 | + |
| 37 | +withCDDLs :: TestTree -> TestTree |
| 38 | +withCDDLs f = withResource |
| 39 | + (do |
| 40 | + probeTools |
| 41 | + setupCDDLCEnv |
| 42 | + BS.writeFile "ntnblock.cddl" . cddlSpec |
| 43 | + =<< (cddlc "cddl/node-to-node/blockfetch/block.cddl" >>= fixupBlockCDDL) |
| 44 | + BS.writeFile "ntnheader.cddl" . cddlSpec |
| 45 | + =<< cddlc "cddl/node-to-node/chainsync/header.cddl" |
| 46 | + ) |
| 47 | + (\() -> do |
| 48 | + D.removeFile "ntnblock.cddl" |
| 49 | + D.removeFile "ntnheader.cddl" |
| 50 | + ) |
| 51 | + (\_ -> f) |
| 52 | + |
| 53 | + |
| 54 | +fixupBlockCDDL :: CDDLSpec -> IO CDDLSpec |
| 55 | +fixupBlockCDDL spec = |
| 56 | + withTempFile "." "block-temp.cddl" $ \fp h -> do |
| 57 | + hClose h |
| 58 | + BS.writeFile fp . cddlSpec $ spec |
| 59 | + -- This is wrong, both the metadata_hash of a pool and a transaction body |
| 60 | + -- point to this type, but only the latter must be 32B. |
| 61 | + sed fp ["-i", "s/\\(metadata_hash = \\)/\\1 bytes ;/g"] |
| 62 | + -- For plutus, the type is actually `bytes`, but the distinct construct is |
| 63 | + -- for forcing generation of different values. |
| 64 | + sed fp ["-i", "s/\\(conway\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"] |
| 65 | + -- These 3 below are hardcoded for generation. See cardano-ledger#5054 |
| 66 | + sed fp ["-i", "s/\\([yaoye]\\.address = \\)/\\1 bytes ;/g"] |
| 67 | + sed fp ["-i", "s/\\(reward_account = \\)/\\1 bytes ;/g"] |
| 68 | + sed fp ["-i", "-z", "s/unit_interval = #6\\.30(\\[\\n\\s*1,\\n\\s*2,\\n\\])/unit_interval = #6.30([uint, uint])/g"] |
| 69 | + CDDLSpec <$> BS.readFile fp |
| 70 | + |
| 71 | +setupCDDLCEnv :: IO () |
| 72 | +setupCDDLCEnv = do |
| 73 | + -- This is not how it should be because we can't update the Ledger |
| 74 | + -- to a newer one. On `master` there is a function |
| 75 | + -- `Byron.readByronCddlFileNames` which we would want to use. |
| 76 | + -- |
| 77 | + -- Note also that cabal run will run in the root of the project and |
| 78 | + -- cabal test will run in `ouroboros-consensus-cardano`. This path |
| 79 | + -- is for the latter. |
| 80 | + byron <- pure ["../../cardano-ledger/eras/byron/cddl-spec/"] |
| 81 | + shelley <- map takePath <$> Shelley.readShelleyCddlFileNames |
| 82 | + allegra <- map takePath <$> Allegra.readAllegraCddlFileNames |
| 83 | + mary <- map takePath <$> Mary.readMaryCddlFileNames |
| 84 | + alonzo <- map takePath <$> Alonzo.readAlonzoCddlFileNames |
| 85 | + babbage <- map takePath <$> Babbage.readBabbageCddlFileNames |
| 86 | + conway <- map takePath <$> Conway.readConwayCddlFileNames |
| 87 | + |
| 88 | + localDataDir <- takePath <$> getDataDir |
| 89 | + let local_paths = map (localDataDir F.</>) [ |
| 90 | + "cddl" |
| 91 | + , "cddl/disk" |
| 92 | + , "cddl/disk/snapshot" |
| 93 | + , "cddl/node-to-client/localstatequery/byron" |
| 94 | + , "cddl/node-to-client/localstatequery/consensus" |
| 95 | + , "cddl/node-to-client/localstatequery/shelley" |
| 96 | + , "cddl/node-to-client/txmonitor" |
| 97 | + ] |
| 98 | + |
| 99 | + include_path = |
| 100 | + mconcat |
| 101 | + $ L.intersperse ":" |
| 102 | + $ map (mconcat . L.intersperse ":") [byron, shelley, allegra, mary, alonzo, babbage, conway] <> local_paths |
| 103 | + |
| 104 | + writeFile "env" ("CDDL_INCLUDE_PATH=" <> include_path <> ":") |
| 105 | + E.setEnv "CDDL_INCLUDE_PATH" (include_path <> ":") |
| 106 | + |
| 107 | +sed :: FilePath -> [String] -> IO () |
| 108 | +sed fp args = |
| 109 | + Monad.void $ P.readProcessWithExitCode "sed" (args ++ [fp]) mempty |
| 110 | + |
| 111 | +cddlc :: FilePath -> IO CDDLSpec |
| 112 | +cddlc dataFile = do |
| 113 | + putStrLn $ "Generating: " <> dataFile |
| 114 | + path <- getDataFileName dataFile |
| 115 | + (_, BSL.toStrict -> cddl, BSL.toStrict -> err) <- |
| 116 | +#ifdef POSIX |
| 117 | + P.readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty |
| 118 | +#else |
| 119 | + -- we cannot call @cddlc@ directly because it is not an executable in |
| 120 | + -- Haskell eyes, but we can call @ruby@ and pass the @cddlc@ script path as |
| 121 | + -- an argument |
| 122 | + do |
| 123 | + prefix <- E.getEnv "MSYSTEM_PREFIX" |
| 124 | + P.readProcessWithExitCode "ruby" [prefix F.</> "bin/cddlc", "-u", "-2", "-t", "cddl", path] mempty |
| 125 | +#endif |
| 126 | + Monad.unless (BS.null err) $ red $ BS8.unpack err |
| 127 | + return $ CDDLSpec cddl |
| 128 | + where |
| 129 | + red s = putStrLn $ "\ESC[31m" <> s <> "\ESC[0m" |
| 130 | + |
| 131 | +takePath :: FilePath -> FilePath |
| 132 | +takePath x = |
| 133 | +#ifdef POSIX |
| 134 | + F.takeDirectory x |
| 135 | +#else |
| 136 | + -- @cddlc@ is not capable of using backlashes |
| 137 | + -- |
| 138 | + -- @cddlc@ mixes @C:@ with the separator in @CDDL_INCLUDE_PATH@, and it |
| 139 | + -- doesn't understand @;@ as a separator. It works if we remove @C:@ and we |
| 140 | + -- are running in the same drive as the cddl files. |
| 141 | + let f = [ if c /= '\\' then c else '/' | c <- F.takeDirectory x ] |
| 142 | + in if "C:" `L.isPrefixOf` f |
| 143 | + then drop 2 f |
| 144 | + else f |
| 145 | +#endif |
| 146 | + |
| 147 | +probeTools :: IO () |
| 148 | +probeTools = do |
| 149 | + putStrLn "Probing tools:" |
| 150 | +#ifdef POSIX |
| 151 | + posixProbeTool "cddlc" "install the `cddlc` ruby gem" |
| 152 | + where |
| 153 | + posixProbeTool :: String -> Sring -> IO () |
| 154 | + posixProbeTool tool suggestion = do |
| 155 | + putStr $ "- " <> tool <> " " |
| 156 | + exe <- D.findExecutable tool |
| 157 | + if isNothing exe |
| 158 | + then do |
| 159 | + putStrLn "not found!" |
| 160 | + putStrLn $ "Please " <> suggestion |
| 161 | + exitFailure |
| 162 | + else |
| 163 | + putStrLn "found" |
| 164 | +#else |
| 165 | + -- On Windows, the cddl and cddlc files are POSIX scripts and therefore not |
| 166 | + -- recognized as executables by @findExecutable@, so we need to do some dirty |
| 167 | + -- tricks here. We check that ruby executable exists and then that there are |
| 168 | + -- cddl and cddlc files in the binary folder of the MSYS2 installation. |
| 169 | + putStr "- ruby " |
| 170 | + rubyExe <- D.findExecutable "ruby" |
| 171 | + if (isNothing rubyExe) |
| 172 | + then do |
| 173 | + putStrLn "not found!\nPlease install ruby" |
| 174 | + exitFailure |
| 175 | + else |
| 176 | + putStrLn "found" |
| 177 | + |
| 178 | + putStr "- cddlc " |
| 179 | + cddlcExe <- D.doesFileExist . (F.</> "bin/cddlc") =<< E.getEnv "MSYSTEM_PREFIX" |
| 180 | + if cddlcExe |
| 181 | + then putStrLn "found" |
| 182 | + else do |
| 183 | + putStrLn "not found!\nPlease install the `cddlc` ruby gem" |
| 184 | + exitFailure |
| 185 | + pure () |
| 186 | +#endif |
0 commit comments