never executed always true always false

    1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE NamedFieldPuns #-}
    3 {-# LANGUAGE OverloadedStrings #-}
    4 
    5 {-# OPTIONS_HADDOCK hide #-}
    6 
    7 module Command.Script.Validation
    8     ( Cmd
    9     , mod
   10     , run
   11 
   12     ) where
   13 
   14 import Prelude hiding
   15     ( mod )
   16 
   17 import Cardano.Address.Script
   18     ( KeyHash
   19     , Script (..)
   20     , ValidationLevel (..)
   21     , prettyErrValidateScript
   22     , validateScript
   23     )
   24 import Data.Maybe
   25     ( fromMaybe )
   26 import Options.Applicative
   27     ( CommandFields
   28     , Mod
   29     , command
   30     , footerDoc
   31     , header
   32     , helper
   33     , info
   34     , optional
   35     , progDesc
   36     )
   37 import Options.Applicative.Help.Pretty
   38     ( bold, indent, string, vsep )
   39 import Options.Applicative.Script
   40     ( levelOpt, scriptArg )
   41 import System.IO
   42     ( stderr, stdout )
   43 import System.IO.Extra
   44     ( hPutString, progName )
   45 
   46 data Cmd = Cmd
   47     { script :: Script KeyHash
   48     , validationLevel :: Maybe ValidationLevel
   49     } deriving (Show)
   50 
   51 mod :: (Cmd -> parent) -> Mod CommandFields parent
   52 mod liftCmd = command "validate" $
   53     info (helper <*> fmap liftCmd parser) $ mempty
   54         <> progDesc "Validate a script"
   55         <> header "Choose a required (default) or recommended validation of a script."
   56         <> footerDoc (Just $ vsep
   57             [ string "The script is taken as argument. To have required validation pass '--required' or nothing."
   58             , string "To have recommended validation pass '--recommended'. Recommended validation adds more validations"
   59             , string "on top of the required one, in particular:"
   60             , string " - check if 'all' is non-empty"
   61             , string " - check if there are redundant timelocks in a given level"
   62             , string " - check if there are no duplicated verification keys in a given level"
   63             , string " - check if 'at_least' coeffcient is positive"
   64             , string " - check if 'all', 'any' are non-empty and `'at_least' has no less elements in the list than the coeffcient after timelocks are filtered out. "
   65             , string "The validation of the script does not take into account transaction validity. We assume that the user will take care of this."
   66             , string ""
   67             , string "Example:"
   68             , indent 2 $ bold $ string $ progName<>" script validate 'all"
   69             , indent 4 $ bold $ string "[ addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   70             , indent 4 $ bold $ string ", addr_shared_vk1jthguyss2vffmszq63xsmxlpc9elxnvdyaqk7susl4sppp2s9xqsuszh44"
   71             , indent 4 $ bold $ string "]'"
   72             , indent 2 $ string "Validated."
   73             , string ""
   74             , indent 2 $ bold $ string $ progName<>" script validate --required 'all"
   75             , indent 4 $ bold $ string "[ addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   76             , indent 4 $ bold $ string ", addr_shared_vk1jthguyss2vffmszq63xsmxlpc9elxnvdyaqk7susl4sppp2s9xqsuszh44"
   77             , indent 4 $ bold $ string "]'"
   78             , indent 2 $ string "Validated."
   79             , string ""
   80             , indent 2 $ bold $ string $ progName<>" script validate --recommended 'all []'"
   81             , indent 2 $ string "Not validated: The list inside a script is empty or only contains timelocks (which is not recommended)."
   82             , string ""
   83             , indent 2 $ bold $ string $ progName<>" script validate 'at_least 1 [active_from 11, active_until 16]'"
   84             , indent 2 $ string "Validated."
   85             , string ""
   86             , indent 2 $ bold $ string $ progName<>" script validate 'all"
   87             , indent 4 $ bold $ string "[ addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   88             , indent 4 $ bold $ string ", addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   89             , indent 4 $ bold $ string "]'"
   90             , indent 2 $ string "Validated."
   91             , string ""
   92             , indent 2 $ bold $ string $ progName<>" script validate --recommended 'all"
   93             , indent 4 $ bold $ string "[ addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   94             , indent 4 $ bold $ string ", addr_shared_vk1wgj79fxw2vmxkp85g88nhwlflkxevd77t6wy0nsktn2f663wdcmqcd4fp3"
   95             , indent 4 $ bold $ string "]'"
   96             , indent 2 $ string "Not validated: The list inside a script has duplicate keys (which is not recommended)."
   97             ])
   98   where
   99     parser = Cmd
  100         <$> scriptArg
  101         <*> optional levelOpt
  102 
  103 run :: Cmd -> IO ()
  104 run Cmd{script,validationLevel} =
  105     case validateScript (fromMaybe RequiredValidation validationLevel) script of
  106         Left err -> hPutString stderr $ "Not validated: " <> prettyErrValidateScript err
  107         Right _ -> hPutString stdout "Validated."