{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Consensus.Cardano.GenCDDLs (withCDDLs) where

import qualified Control.Monad as Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as L
import Data.Maybe (isNothing)
import Paths_ouroboros_consensus_cardano
import qualified System.Directory as D
import qualified System.Environment as E
import System.Exit
import qualified System.FilePath as F
import System.IO
import System.IO.Temp
import qualified System.Process.ByteString.Lazy as P
import qualified Test.Cardano.Chain.Binary.Cddl as Byron
import qualified Test.Cardano.Ledger.Allegra.Binary.Cddl as Allegra
import qualified Test.Cardano.Ledger.Alonzo.Binary.Cddl as Alonzo
import qualified Test.Cardano.Ledger.Babbage.Binary.Cddl as Babbage
import qualified Test.Cardano.Ledger.Conway.Binary.Cddl as Conway
import qualified Test.Cardano.Ledger.Dijkstra.Binary.Cddl as Dijkstra
import qualified Test.Cardano.Ledger.Mary.Binary.Cddl as Mary
import qualified Test.Cardano.Ledger.Shelley.Binary.Cddl as Shelley
import Test.Tasty
import Test.Util.Serialisation.CDDL (isCDDLCDisabled)

newtype CDDLSpec = CDDLSpec {CDDLSpec -> ByteString
cddlSpec :: BS.ByteString} deriving Int -> CDDLSpec -> ShowS
[CDDLSpec] -> ShowS
CDDLSpec -> String
(Int -> CDDLSpec -> ShowS)
-> (CDDLSpec -> String) -> ([CDDLSpec] -> ShowS) -> Show CDDLSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CDDLSpec -> ShowS
showsPrec :: Int -> CDDLSpec -> ShowS
$cshow :: CDDLSpec -> String
show :: CDDLSpec -> String
$cshowList :: [CDDLSpec] -> ShowS
showList :: [CDDLSpec] -> ShowS
Show

-- | This function will run the provided test-tree after generating the node to
-- node cddls for Blocks and Headers. As more CDDLs are stabilized they will
-- have to be added here. Eventually we can have a datatype with one field for
-- each CDDL so that we know always what is available.
withCDDLs :: TestTree -> TestTree
withCDDLs :: TestTree -> TestTree
withCDDLs TestTree
f =
  if Bool
isCDDLCDisabled
    then TestTree
f
    else
      IO () -> (() -> IO ()) -> (IO () -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource
        ( do
            IO ()
probeTools
            IO ()
setupCDDLCEnv

            ntnBlock <- String -> IO CDDLSpec
cddlc String
"cddl/node-to-node/blockfetch/block.cddl"
            ntnBlock' <- fixupBlockCDDL ntnBlock
            BS.writeFile "ntnblock.cddl" . cddlSpec $ ntnBlock'

            ntnHeader <- cddlc "cddl/node-to-node/chainsync/header.cddl"
            BS.writeFile "ntnheader.cddl" . cddlSpec $ ntnHeader

            ntnTx <- cddlc "cddl/node-to-node/txsubmission2/tx.cddl"
            ntnTx' <- fixupBlockCDDL ntnTx
            BS.writeFile "ntntx.cddl" . cddlSpec $ ntnTx'

            ntnTxId <- cddlc "cddl/node-to-node/txsubmission2/txId.cddl"
            BS.writeFile "ntntxid.cddl" . cddlSpec $ ntnTxId
        )
        ( \() -> do
            String -> IO ()
D.removeFile String
"ntnblock.cddl"
            String -> IO ()
D.removeFile String
"ntnheader.cddl"
            String -> IO ()
D.removeFile String
"ntntx.cddl"
            String -> IO ()
D.removeFile String
"ntntxid.cddl"
        )
        (\IO ()
_ -> TestTree
f)

-- | The Ledger CDDL specs are not _exactly_ correct. Here we do some dirty
-- sed-replace to make them able to validate blocks. See cardano-ledger#5054.
fixupBlockCDDL :: CDDLSpec -> IO CDDLSpec
fixupBlockCDDL :: CDDLSpec -> IO CDDLSpec
fixupBlockCDDL CDDLSpec
spec =
  String
-> String -> (String -> Handle -> IO CDDLSpec) -> IO CDDLSpec
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile String
"." String
"block-temp.cddl" ((String -> Handle -> IO CDDLSpec) -> IO CDDLSpec)
-> (String -> Handle -> IO CDDLSpec) -> IO CDDLSpec
forall a b. (a -> b) -> a -> b
$ \String
fp Handle
h -> do
    Handle -> IO ()
hClose Handle
h
    String -> ByteString -> IO ()
BS.writeFile String
fp (ByteString -> IO ())
-> (CDDLSpec -> ByteString) -> CDDLSpec -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDDLSpec -> ByteString
cddlSpec (CDDLSpec -> IO ()) -> CDDLSpec -> IO ()
forall a b. (a -> b) -> a -> b
$ CDDLSpec
spec
    -- For plutus, the type is actually `bytes`, but the distinct construct is
    -- for forcing generation of different values. See cardano-ledger#5054
    String -> [String] -> IO ()
sed String
fp [String
"-i", String
"s/\\(conway\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"]
    String -> [String] -> IO ()
sed String
fp [String
"-i", String
"s/\\(dijkstra\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"]
    -- These 3 below are hardcoded for generation. See cardano-ledger#5054
    String -> [String] -> IO ()
sed String
fp [String
"-i", String
"s/\\([yaoye]\\.address = \\)/\\1 bytes ;/g"]
    String -> [String] -> IO ()
sed String
fp [String
"-i", String
"s/\\(reward_account = \\)/\\1 bytes ;/g"]
    String -> [String] -> IO ()
sed
      String
fp
      [ String
"-i"
      , String
"-z"
      , String
"s/unit_interval = #6\\.30(\\[\\n\\s*1,\\n\\s*2,\\n\\])/unit_interval = #6.30([uint, uint])/g"
      ]

    -- for convenience, we use this test suite to generate the complete CDDL spec for manual testing.
    -- while this sed replacement is not used in these tests, it is needed to validate some of the real blocks.
    String -> [String] -> IO ()
sed String
fp [String
"-i", String
"s/\\(chain_code: bytes\\)/\\1, ;/g"]
    ByteString -> CDDLSpec
CDDLSpec (ByteString -> CDDLSpec) -> IO ByteString -> IO CDDLSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp

-- | This sets the environment variables needed for `cddlc` to run properly.
setupCDDLCEnv :: IO ()
setupCDDLCEnv :: IO ()
setupCDDLCEnv = do
  byron <- ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takePath ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
Byron.readByronCddlFileNames
  shelley <- map takePath <$> Shelley.readShelleyCddlFileNames
  allegra <- map takePath <$> Allegra.readAllegraCddlFileNames
  mary <- map takePath <$> Mary.readMaryCddlFileNames
  alonzo <- map takePath <$> Alonzo.readAlonzoCddlFileNames
  babbage <- map takePath <$> Babbage.readBabbageCddlFileNames
  conway <- map takePath <$> Conway.readConwayCddlFileNames
  dijkstra <- map takePath <$> Dijkstra.readDijkstraCddlFileNames

  localDataDir <- windowsPathHack <$> getDataDir
  let local_paths =
        ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
          (String
localDataDir String -> ShowS
F.</>)
          [String
"cddl"] -- Directories with other cddls that we import should go here
      include_path =
        [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
":" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
            ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
":") [[String]
byron, [String]
shelley, [String]
allegra, [String]
mary, [String]
alonzo, [String]
babbage, [String]
conway, [String]
dijkstra]
              [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
local_paths

  E.setEnv "CDDL_INCLUDE_PATH" (include_path <> ":")

-- | Call @sed@ on the given file with the given args
sed :: FilePath -> [String] -> IO ()
sed :: String -> [String] -> IO ()
sed String
fp [String]
args =
  IO (ExitCode, ByteString, ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (IO (ExitCode, ByteString, ByteString) -> IO ())
-> IO (ExitCode, ByteString, ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
P.readProcessWithExitCode String
"sed" ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
fp]) ByteString
forall a. Monoid a => a
mempty

{- FOURMOLU_DISABLE -}

cddlc :: FilePath -> IO CDDLSpec
cddlc :: String -> IO CDDLSpec
cddlc String
dataFile = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Generating: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dataFile
  path <- String -> IO String
getDataFileName String
dataFile
  (exitCode, BSL.toStrict -> cddl, BSL.toStrict -> err) <-
#ifdef mingw32_HOST_OS
    -- we cannot call @cddlc@ directly because it is not an executable in
    -- Haskell eyes, but we can call @ruby@ and pass the @cddlc@ script path as
    -- an argument
    do
    prefix <- E.getEnv "MSYSTEM_PREFIX"
    P.readProcessWithExitCode "ruby" [prefix F.</> "bin/cddlc", "-u", "-2", "-t", "cddl", path] mempty
#else
    P.readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty
#endif
  case exitCode of
    ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExitFailure{} ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (ByteString -> Bool
BS.null ByteString
err) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
red (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS8.unpack ByteString
err
  return $ CDDLSpec cddl
 where
  red :: String -> IO ()
red String
s = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\ESC[31m" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[0m"

-- | @cddlc@ is not capable of using backlashes
--
-- @cddlc@ mixes @C:@ with the separator in @CDDL_INCLUDE_PATH@, and it
-- doesn't understand @;@ as a separator. It works if we remove @C:@ and we
-- are running in the same drive as the cddl files.
windowsPathHack :: FilePath -> FilePath
windowsPathHack :: ShowS
windowsPathHack String
x =
#ifdef mingw32_HOST_OS
  let f = [ if c /= '\\' then c else '/' | c <- x ]
  in if "C:" `L.isPrefixOf` f
     then drop 2 f
     else f
#else
  String
x
#endif

takePath :: FilePath -> FilePath
takePath :: ShowS
takePath = ShowS
windowsPathHack ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
F.takeDirectory

probeTools :: IO ()
probeTools :: IO ()
probeTools = do
  String -> IO ()
putStrLn String
"Probing tools:"
#ifdef mingw32_HOST_OS
  -- On Windows, the cddl and cddlc files are POSIX scripts and therefore not
  -- recognized as executables by @findExecutable@, so we need to do some dirty
  -- tricks here. We check that ruby executable exists and then that there are
  -- cddl and cddlc files in the binary folder of the MSYS2 installation.
  putStr "- ruby "
  rubyExe <- D.findExecutable "ruby"
  if (isNothing rubyExe)
  then do
    putStrLn "not found!\nPlease install ruby"
    exitFailure
  else
    putStrLn "found"

  putStr "- cddlc "
  cddlcExe <- D.doesFileExist . (F.</> "bin/cddlc") =<< E.getEnv "MSYSTEM_PREFIX"
  if cddlcExe
  then putStrLn "found"
  else do
    putStrLn "not found!\nPlease install the `cddlc` ruby gem"
    exitFailure
  pure ()
#else
  String -> String -> IO ()
posixProbeTool String
"cddlc" String
"install the `cddlc` ruby gem"
  where
    posixProbeTool :: String -> String -> IO ()
    posixProbeTool :: String -> String -> IO ()
posixProbeTool String
tool String
suggestion = do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
tool String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
      exe <- String -> IO (Maybe String)
D.findExecutable String
tool
      if isNothing exe
      then do
        putStrLn "not found!"
        putStrLn $ "Please " <> suggestion
        exitFailure
      else
        putStrLn "found"
#endif

{- FOURMOLU_ENABLE -}