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