├── .gitignore ├── .haskell-ci ├── LICENSE ├── README.md ├── Setup.hs ├── example └── Main.hs ├── inspector.cabal ├── package.yaml ├── src ├── Inspector.hs └── Inspector │ ├── Builder.hs │ ├── Export │ ├── Diff.hs │ ├── Markdown.hs │ ├── RefFile.hs │ ├── Rust.hs │ └── Types.hs │ ├── Method.hs │ ├── Monad.hs │ ├── Parser.hs │ ├── Report.hs │ └── TestVector │ ├── Key.hs │ ├── TestVector.hs │ ├── Types.hs │ └── Value.hs ├── stack.yaml └── tests └── goldens ├── hash ├── SHA1 └── SHA256 └── kdf └── PBKDF2 └── SHA1 /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | ghcid.txt 3 | *swp 4 | -------------------------------------------------------------------------------- /.haskell-ci: -------------------------------------------------------------------------------- 1 | # compiler supported and their equivalent LTS 2 | compiler: ghc-8.2 lts-10.5 3 | compiler: ghc-8.4 nightly-2018-06-10 4 | 5 | # options 6 | 7 | # builds 8 | build: ghc-8.2 extradep=basement-0.0.7 extradep=foundation-0.0.20 extradep=memory-0.14.15 extradep=cryptonite-0.25 9 | build: ghc-8.4 extradep=basement-0.0.7 extradep=foundation-0.0.20 extradep=memory-0.14.15 extradep=cryptonite-0.25 10 | 11 | # packages 12 | package: '.' 13 | 14 | # extra builds 15 | hlint: allowed-failure 16 | weeder: allowed-failure 17 | coverall: false 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017-2018, Prime Type Ltd 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # inspector 2 | 3 | Futuristic Golden Test Managements. 4 | 5 | Define the Inspector script, such as the following: 6 | 7 | ```haskell 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Main (main) where 14 | 15 | import Inspector 16 | 17 | import Foundation 18 | import Data.ByteArray (Bytes) 19 | 20 | import Crypto.Hash 21 | import Crypto.KDF.PBKDF2 (fastPBKDF2_SHA1, Parameters (..)) 22 | 23 | type GoldenSHA1 = "hash" :> "SHA1" :> Payload "payload" String :> Payload "hash" (Digest SHA1) 24 | type GoldenSHA256 = "hash" :> "SHA256" :> Payload "payload" String :> Payload "hash" (Digest SHA256) 25 | 26 | type GoldenPBKDF2 = "kdf" :> "PBKDF2" :> "SHA1" 27 | :> Payload "iter" Int :> Payload "size" Int :> Payload "password" String :> Payload "salt" String :> Payload "hash" Bytes 28 | 29 | main :: IO () 30 | main = defaultMain $ do 31 | golden (Proxy @GoldenSHA1) hash 32 | golden (Proxy @GoldenSHA256) hash 33 | golden (Proxy @GoldenPBKDF2) $ \iter len pwd salt -> 34 | fastPBKDF2_SHA1 (Parameters iter len) pwd salt 35 | ``` 36 | 37 | And now write the appropriate test vectors: 38 | 39 | for example, for the SHA1's Test Vectors: 40 | 41 | * First you create the initial test vectors with the input only: 42 | 43 | ```shell 44 | TestVector 45 | payload = "" 46 | 47 | TestVector 48 | payload = "The quick brown fox jumps over the lazy dog" 49 | 50 | TestVector 51 | payload = "The quick brown fox jumps over the lazy cog" 52 | ``` 53 | 54 | * then you execute the Inspector script with the `generate` option. 55 | It will provide the following output: 56 | 57 | ```shell 58 | # Test Vector 1 59 | TestVector 60 | hash = "da39a3ee5e6b4b0d3255bfef95601890afd80709" 61 | payload = "" 62 | 63 | # Test Vector 2 64 | TestVector 65 | hash = "2fd4e1c67a2d28fced849ee1bb76e7391b93eb12" 66 | payload = "The quick brown fox jumps over the lazy dog" 67 | 68 | # Test Vector 3 69 | TestVector 70 | hash = "de9f2c7fd25e1b3afad3e85a0bd17d9b100db4b3" 71 | payload = "The quick brown fox jumps over the lazy cog" 72 | 73 | ``` 74 | 75 | # Future enhancements: 76 | 77 | - [ ] generate pretty Markdown output 78 | - [ ] generate ready to use C test vectors 79 | - [ ] generate ready to use Rust test vectors 80 | - [ ] generate ready to use JS test vectors 81 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Main (main) where 7 | 8 | import Inspector 9 | import qualified Inspector.TestVector.Types as Type 10 | import qualified Inspector.TestVector.Value as Value 11 | 12 | import Foundation 13 | import Foundation.Check (Arbitrary(..)) 14 | import Data.ByteArray (Bytes) 15 | 16 | import Crypto.Hash 17 | import Crypto.KDF.PBKDF2 (fastPBKDF2_SHA1, Parameters (..)) 18 | 19 | type GoldenSHA1 = "hash" :> "SHA1" :> Payload "payload" String :> Payload "hash" (Digest SHA1) 20 | type GoldenSHA256 = "hash" :> "SHA256" :> Payload "payload" String :> Payload "hash" (Digest SHA256) 21 | 22 | type GoldenPBKDF2 = "kdf" :> "PBKDF2" :> "SHA1" 23 | :> Payload "parameters" Parameters :> Payload "password" String :> Payload "salt" String :> Payload "hash" Bytes 24 | 25 | main :: IO () 26 | main = defaultTest $ do 27 | group $ do 28 | summary "Secure Hash Algorithm" 29 | golden (Proxy @GoldenSHA1) hash 30 | golden (Proxy @GoldenSHA256) hash 31 | group $ do 32 | summary "Password-Based Key Derivation" 33 | golden (Proxy @GoldenPBKDF2) $ \params pwd salt -> 34 | fastPBKDF2_SHA1 params pwd salt 35 | 36 | instance Arbitrary Parameters where 37 | arbitrary = undefined 38 | 39 | instance Inspectable Parameters where 40 | documentation _ = "PBKDF2 Parameters." 41 | exportType _ = Type.Object $ Type.ObjectDef 42 | [ ("iter", Type.Signed64) 43 | , ("len", Type.Signed64) 44 | ] 45 | builder (Parameters iter len) = Value.Object $ Value.ObjectDef 46 | [ ("iter", builder iter) 47 | , ("len", builder len) 48 | ] 49 | parser = withStructure "Parameters" $ \obj -> do 50 | iter <- parser =<< field obj "iter" 51 | len <- parser =<< field obj "len" 52 | pure $ Parameters iter len 53 | -------------------------------------------------------------------------------- /inspector.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 076fc959ff612b7b889c8f02ce5082b559a2a577496054a6777a4b71b2ba1938 6 | 7 | name: inspector 8 | version: 0.2 9 | category: Testing 10 | homepage: https://github.com/primetype/inspector#readme 11 | author: Nicolas Di Prima 12 | maintainer: nicolas@primetype.co.uk 13 | copyright: 2017-2018 PrimeType Ltd 14 | license: BSD3 15 | license-file: LICENSE 16 | build-type: Simple 17 | cabal-version: >= 1.10 18 | extra-source-files: 19 | LICENSE 20 | README.md 21 | 22 | library 23 | hs-source-dirs: 24 | src 25 | default-extensions: NoImplicitPrelude TypeFamilies DataKinds OverloadedStrings 26 | ghc-options: -Wall -Werror 27 | build-depends: 28 | base 29 | , basement >=0.0.7 30 | , cryptonite 31 | , foundation >=0.0.20 32 | , memory >=0.14.15 33 | exposed-modules: 34 | Inspector 35 | Inspector.TestVector.Types 36 | Inspector.TestVector.Value 37 | other-modules: 38 | Inspector.Method 39 | Inspector.Monad 40 | Inspector.Export.Markdown 41 | Inspector.Export.Rust 42 | Inspector.Export.Types 43 | Inspector.Export.RefFile 44 | Inspector.Export.Diff 45 | Inspector.Parser 46 | Inspector.Builder 47 | Inspector.TestVector.Key 48 | Inspector.TestVector.TestVector 49 | default-language: Haskell2010 50 | 51 | executable example 52 | main-is: Main.hs 53 | hs-source-dirs: 54 | example/ 55 | default-extensions: NoImplicitPrelude TypeFamilies DataKinds OverloadedStrings 56 | ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N 57 | build-depends: 58 | base 59 | , basement >=0.0.7 60 | , cryptonite 61 | , foundation >=0.0.20 62 | , inspector 63 | , memory >=0.14.15 64 | other-modules: 65 | Paths_inspector 66 | default-language: Haskell2010 67 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: inspector 2 | version: "0.2" 3 | homepage: https://github.com/primetype/inspector#readme 4 | license: BSD3 5 | author: Nicolas Di Prima 6 | maintainer: nicolas@primetype.co.uk 7 | copyright: 2017-2018 PrimeType Ltd 8 | category: Testing 9 | extra-source-files: 10 | - README.md 11 | - LICENSE 12 | 13 | dependencies: 14 | - base 15 | - basement >= 0.0.7 16 | - foundation >= 0.0.20 17 | - memory >= 0.14.15 18 | - cryptonite 19 | 20 | default-extensions: 21 | - NoImplicitPrelude 22 | - TypeFamilies 23 | - DataKinds 24 | - OverloadedStrings 25 | 26 | ghc-options: 27 | - -Wall 28 | - -Werror 29 | 30 | library: 31 | source-dirs: src 32 | exposed-modules: 33 | - Inspector 34 | - Inspector.TestVector.Types 35 | - Inspector.TestVector.Value 36 | other-modules: 37 | - Inspector.Method 38 | - Inspector.Monad 39 | # - Inspector.Report 40 | - Inspector.Export.Markdown 41 | - Inspector.Export.Rust 42 | - Inspector.Export.Types 43 | - Inspector.Export.RefFile 44 | - Inspector.Export.Diff 45 | - Inspector.Parser 46 | - Inspector.Builder 47 | - Inspector.TestVector.Key 48 | - Inspector.TestVector.TestVector 49 | 50 | executables: 51 | example: 52 | main: Main.hs 53 | source-dirs: example/ 54 | dependencies: 55 | - inspector 56 | ghc-options: 57 | - -threaded 58 | - -rtsopts 59 | - -with-rtsopts=-N 60 | -------------------------------------------------------------------------------- /src/Inspector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module Inspector 6 | ( -- * Golden Test 7 | Golden 8 | , golden 9 | , group 10 | , summary 11 | 12 | , -- ** defining a golden test 13 | Payload 14 | , (:>) 15 | , PathParameter 16 | 17 | , -- ** Extending Inspectable 18 | Inspectable(..) 19 | , reportError 20 | , OutputType(..) 21 | , withBoolean 22 | , withInteger 23 | , withDouble 24 | , withString 25 | , withCollection 26 | , withStructure 27 | , field 28 | 29 | , -- * Misc 30 | Config(..) 31 | , Mode(..) 32 | , defaultTest 33 | , GoldenMT 34 | , GoldenT 35 | ) where 36 | 37 | import Inspector.Monad 38 | import Inspector.Method 39 | import Inspector.Export.Types 40 | import Inspector.Export.RefFile 41 | import qualified Inspector.Export.RefFile as RefFile 42 | import qualified Inspector.Export.Diff as Diff 43 | import qualified Inspector.Export.Rust as Rust 44 | import qualified Inspector.Export.Markdown as Markdown 45 | 46 | import Inspector.TestVector.Types (Type) 47 | import Inspector.TestVector.Value (Value) 48 | import Inspector.TestVector.TestVector (Entry(..), TestVector) 49 | 50 | import Basement.Terminal as Terminal (initialize) 51 | 52 | import Foundation 53 | import Foundation.Monad 54 | import Foundation.Conduit 55 | import Foundation.VFS.FilePath 56 | 57 | import GHC.TypeLits (KnownSymbol) 58 | 59 | import Control.Monad (void, when) 60 | import System.Console.GetOpt 61 | import qualified System.Environment as S (getArgs) 62 | 63 | -- | handy one for test suite for cabal 64 | defaultTest :: GoldenT () -> IO () 65 | defaultTest suites = do 66 | Terminal.initialize 67 | args <- S.getArgs 68 | (opts, command) <- case getOpt Permute options args of 69 | (o, cmd, []) -> return (o, cmd) 70 | (_, _, err) -> error $ show err 71 | case command of 72 | [] -> runCommandTest opts suites 73 | ["help"] -> usage 74 | ["test"] -> runCommandTest opts suites 75 | ["generate"] -> runCommandGenerate opts "test-vectors" suites 76 | ["generate", target] -> runCommandGenerate opts target suites 77 | _ -> usage >> error ("invalid commands: " <> show command) 78 | where 79 | usage = putStrLn "\ 80 | \usage: inspector [OPTIONS] [COMMANDS]\n\ 81 | \\n\ 82 | \OPTIONS:\n\ 83 | \ `-d|--root ' the route directory where the golden tests are (default `./tests/goldens')\n\ 84 | \ `--stdout' display the generated output to stdout instead of files\n\ 85 | \\n\ 86 | \COMMANDS:\n\ 87 | \ `help' displays this help message\n\ 88 | \ `test' runs the golden tests suite (default command if none given)\n\ 89 | \ `generate [TARGET]' generates the outputs for different test suites : `rust' or `markdown'\n\ 90 | \\n\ 91 | \" 92 | 93 | data InspectorOption 94 | = RootDir LString 95 | | GenStdout 96 | deriving (Show, Eq, Ord, Typeable) 97 | 98 | options :: [OptDescr InspectorOption] 99 | options = 100 | [ Option ['d'] ["root"] (ReqArg RootDir "DIR") "root directory of the golden test path" 101 | , Option [] ["stdout"] (NoArg GenStdout) "generate to stdout" 102 | ] 103 | 104 | getRootDir :: [InspectorOption] -> FilePath 105 | getRootDir [] = "tests/goldens" 106 | getRootDir (RootDir dir:_) = fromString (fromList dir) 107 | getRootDir (_: xs) = getRootDir xs 108 | 109 | getStdoutOpt :: [InspectorOption] -> Bool 110 | getStdoutOpt [] = False 111 | getStdoutOpt (GenStdout : _) = True 112 | getStdoutOpt (_:xs) = getStdoutOpt xs 113 | 114 | runCommandTest :: [InspectorOption] -> GoldenT () -> IO () 115 | runCommandTest o suites = void $ runGolden' (Config GoldenTest (getRootDir o) (getStdoutOpt o)) $ do 116 | void $ suites 117 | t <- goldenTFailed 118 | when t $ error "Failed due to previous errors." 119 | 120 | runCommandGenerate :: [InspectorOption] -> LString -> GoldenT () -> IO () 121 | runCommandGenerate o target suites = case target of 122 | "test-vectors" -> generate (Generate TestVectors) 123 | "rust" -> generate (Generate Rust) 124 | "markdown" -> generate (Generate Markdown) 125 | _ -> error $ "unknown target: " <> show target 126 | where 127 | generate gen = void $ runGolden' (Config gen (getRootDir o) (getStdoutOpt o)) $ do 128 | void suites 129 | t <- goldenTFailed 130 | when t $ error "Failed due to previous errors." 131 | 132 | -- | group a set of golden tests 133 | group :: GoldenT () -> GoldenT () 134 | group = id -- void . exec 135 | 136 | -- | generate the golden test from the specification and the method 137 | -- 138 | -- @ 139 | -- import Crypto.Hash (hash, Digest, SHA1) 140 | -- 141 | -- type GoldenSHA1 = "hash" :> "SHA1" :> Payload "payload" String :> Payload "hash" (Digest SHA1) 142 | -- golden (Proxy @GoldenSHA1) hash 143 | -- @ 144 | -- 145 | golden :: Golden method 146 | => Proxy method 147 | -> Method method 148 | -> GoldenT () 149 | golden proxy action = do 150 | mode <- getMode <$> ask 151 | 152 | file <- mkPath input 153 | -- 1. collect the testvectors 154 | !tv1 <- liftIO $ toList <$> parseTestVectorFile file 155 | -- 2. run the method against each TestVector 156 | !tv2 <- runConduit $ yields tv1 .| traverseWith store proxy action .| sinkList 157 | -- 3. keep only result 158 | let tv3 = flip fmap tv2 $ \(a,_,c) -> (a, c) 159 | case mode of 160 | GoldenTest -> Diff.run input tv3 161 | Generate Rust -> Rust.run input tv3 162 | Generate Markdown -> Markdown.run input tv3 163 | Generate TestVectors -> RefFile.run input tv3 164 | where 165 | input :: FilePath 166 | input = unsafeFilePath Relative path' 167 | 168 | path' = getPath proxy 169 | 170 | traverseWith :: forall method c . (Golden method, Monoid c) 171 | => (forall a k . (IsValue a, KnownSymbol k) => Proxy k -> Entry (Type, Value, a) -> GoldenMT c IO ()) 172 | -> Proxy method 173 | -> Method method 174 | -> Conduit (TestVector ()) (Word, TestVector (), c) GoldenT () 175 | traverseWith f proxy action = awaitIndex $ \idx dict -> do 176 | c <- lift $ exec $ method proxy action f dict 177 | yield (idx, dict, c) 178 | 179 | awaitIndex :: (Word -> input -> Conduit input output m b) -> Conduit input output m () 180 | awaitIndex f = go 1 181 | where 182 | go acc = do 183 | mv <- await 184 | case mv of 185 | Nothing -> pure () 186 | Just v -> f acc v >> go (succ acc) 187 | -------------------------------------------------------------------------------- /src/Inspector/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Inspector.Builder 4 | ( Builder 5 | , runBuilder 6 | 7 | , newline 8 | , emit 9 | , indent 10 | , unindent 11 | ) where 12 | 13 | import Foundation 14 | import Foundation.Monad 15 | import Foundation.Monad.State 16 | 17 | import qualified Foundation.String.Builder as Builder 18 | 19 | import Control.Monad (when) 20 | 21 | newtype Indentation = Indentation [String] 22 | deriving (Show, Eq, Semigroup, Monoid) 23 | instance IsList Indentation where 24 | type Item Indentation = String 25 | toList (Indentation l) = l 26 | fromList = Indentation 27 | 28 | getIndent :: Indentation -> String 29 | getIndent (Indentation []) = mempty 30 | getIndent (Indentation (x:xs)) = x <> getIndent (Indentation xs) 31 | 32 | popIndent :: Indentation -> Indentation 33 | popIndent (Indentation []) = Indentation [] 34 | popIndent (Indentation (_:xs)) = Indentation xs 35 | 36 | pushIndent :: Indentation -> String -> Indentation 37 | pushIndent (Indentation xs) x = Indentation (x:xs) 38 | 39 | data BuilderState = BuilderState 40 | { currentIndentation :: Indentation 41 | , currentBuilder :: Builder.Builder 42 | , currentStatus :: BuilderStatus 43 | } 44 | data BuilderStatus = BSNone | BSStarted 45 | deriving (Show, Eq, Ord, Enum, Bounded) 46 | 47 | defaultState :: BuilderState 48 | defaultState = BuilderState 49 | { currentIndentation = mempty 50 | , currentBuilder = mempty 51 | , currentStatus = BSNone 52 | } 53 | 54 | newtype Builder a = Builder { runBuilder_ :: StateT BuilderState Identity a } 55 | deriving (Functor, Applicative, Monad) 56 | 57 | runBuilder :: Builder a -> String 58 | runBuilder builder = 59 | let Identity (_, st) = runStateT (runBuilder_ builder) defaultState 60 | in Builder.toString (currentBuilder st) 61 | 62 | asks :: (BuilderState -> b) -> Builder b 63 | asks f = Builder $ withState $ \st -> (f st, st) 64 | 65 | update :: (BuilderState -> BuilderState) -> Builder () 66 | update f = Builder $ withState $ \st -> ((), f st) 67 | 68 | appendBuilder :: Builder.Builder -> Builder () 69 | appendBuilder builder = update $ \st -> st { currentBuilder = currentBuilder st <> builder } 70 | 71 | newline :: Builder () 72 | newline = do 73 | appendBuilder $ Builder.emitChar '\n' 74 | update $ \st -> st { currentStatus = BSNone } 75 | 76 | indent :: CountOf Char -> Builder () 77 | indent n = update $ \st -> st 78 | { currentIndentation = pushIndent (currentIndentation st) (replicate n ' ') 79 | } 80 | 81 | unindent :: Builder () 82 | unindent = update $ \st -> st 83 | { currentIndentation = popIndent (currentIndentation st) } 84 | 85 | emitIndent :: Builder () 86 | emitIndent = do 87 | i <- asks $ getIndent . currentIndentation 88 | appendBuilder $ Builder.emit i 89 | update $ \st -> st { currentStatus = BSStarted } 90 | 91 | emit :: String -> Builder () 92 | emit str = do 93 | st <- asks currentStatus 94 | when (st == BSNone) emitIndent 95 | appendBuilder (Builder.emit str) -------------------------------------------------------------------------------- /src/Inspector/Export/Diff.hs: -------------------------------------------------------------------------------- 1 | module Inspector.Export.Diff 2 | ( run 3 | ) where 4 | 5 | import Foundation 6 | import Foundation.VFS.FilePath (FilePath, filePathToString) 7 | import Basement.Bounded (zn64) 8 | import qualified Basement.Terminal.ANSI as ANSI 9 | import Foundation.Monad 10 | 11 | import Control.Monad (forM_, unless) 12 | 13 | import Inspector.Monad (GoldenT, goldenTFail) 14 | 15 | import Inspector.Builder (runBuilder) 16 | import Inspector.TestVector.TestVector (TestVector, Entry(..), inputs, outputs) 17 | import Inspector.TestVector.Value (Value, valueBuilder) 18 | import Inspector.TestVector.Types (Type) 19 | import Inspector.TestVector.Key (keyToString) 20 | 21 | run :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> GoldenT () 22 | run path tvs = do 23 | -- 1. check the results of the testvectors 24 | let warningsAndFailures = filter isWarningOrError tvs 25 | let faillures = filter isInvalid tvs 26 | let successes = filter isValid tvs 27 | 28 | unless (null faillures) goldenTFail 29 | 30 | -- 2. print the summary 31 | runTestSummary path faillures successes 32 | 33 | -- 3. display fails 34 | forM_ warningsAndFailures displayFaillure 35 | 36 | runTestSummary :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> [(Word, TestVector (Type, Value, Value))] -> GoldenT () 37 | runTestSummary path faillures successes = do 38 | let numFails = fromCount $ length faillures 39 | let numSuccs = fromCount $ length successes 40 | let totals = numFails + numSuccs 41 | 42 | liftIO $ putStr $ if null faillures 43 | then green <> " ✓ " <> reset 44 | else red <> " ✗ " <> reset 45 | 46 | liftIO $ putStrLn $ filePathToString path 47 | <> ": " 48 | <> show numSuccs <> "/" <> show totals 49 | 50 | displayFaillure :: (Word, TestVector (Type, Value, Value)) -> GoldenT () 51 | displayFaillure (w, tv) = liftIO $ do 52 | putStrLn $ darkGrey <> " >>> TestVector " <> ligthGrey <> show w <> reset 53 | forM_ (inputs tv) $ report green orange "Warning: input may not be the same or may not be serialised the same way." 54 | forM_ (outputs tv) $ report green red "Error" 55 | where 56 | report ok ko msg ent = do 57 | let key = keyToString $ entryKey ent 58 | let (t, v1, v2) = entryExtra ent 59 | unless (v1 == v2) $ do 60 | let str1 = runBuilder $ valueBuilder v1 t 61 | let str2 = runBuilder $ valueBuilder v2 t 62 | putStrLn $ ko <> " >>> " <> msg <> reset 63 | putStrLn $ ko <> " - " <> key <> " = " <> str1 <> reset 64 | putStrLn $ ok <> " + " <> key <> " = " <> str2 <> reset 65 | 66 | reset, green, red, orange, darkGrey, ligthGrey :: ANSI.Escape 67 | reset = ANSI.sgrReset 68 | green = ANSI.sgrForeground (zn64 2) True 69 | orange = ANSI.sgrForeground (zn64 3) True 70 | red = ANSI.sgrForeground (zn64 1) True 71 | ligthGrey = ANSI.sgrForeground (zn64 6) True 72 | darkGrey = ANSI.sgrForeground (zn64 6) False 73 | 74 | isWarningOrError :: (Word, TestVector (Type, Value, Value)) -> Bool 75 | isWarningOrError (_, tv) = or $ entryInvalid <$> (inputs tv <> outputs tv) 76 | where 77 | entryInvalid ent = v1 /= v2 78 | where 79 | (_, v1, v2) = entryExtra ent 80 | 81 | isInvalid :: (Word, TestVector (Type, Value, Value)) -> Bool 82 | isInvalid (_, tv) = or $ entryInvalid <$> outputs tv 83 | where 84 | entryInvalid ent = v1 /= v2 85 | where 86 | (_, v1, v2) = entryExtra ent 87 | 88 | isValid :: (Word, TestVector (Type, Value, Value)) -> Bool 89 | isValid (_, tv) = and $ entryValid <$> outputs tv 90 | where 91 | entryValid ent = v1 == v2 92 | where 93 | (_, v1, v2) = entryExtra ent -------------------------------------------------------------------------------- /src/Inspector/Export/Markdown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | module Inspector.Export.Markdown 6 | ( run 7 | ) where 8 | 9 | import Foundation 10 | import Foundation.Collection (nonEmpty_) 11 | import Foundation.Monad 12 | import Foundation.IO (withFile, IOMode(..), hPut) 13 | import Foundation.VFS.FilePath 14 | import Foundation.String (toBytes, Encoding(UTF8)) 15 | 16 | import Control.Monad (forM_, mapM_) 17 | 18 | import Inspector.Monad (GoldenT, Config(..), ask, mkPath) 19 | import Inspector.Builder 20 | import Inspector.TestVector.TestVector (TestVector, Entry(..), inputs, outputs) 21 | import Inspector.TestVector.Value (Value, valueBuilder) 22 | import Inspector.TestVector.Types (Type) 23 | import Inspector.TestVector.Key (keyToString) 24 | 25 | run :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> GoldenT () 26 | run path tvs = do 27 | stdout <- getStdout <$> ask 28 | fp <- mkfp 29 | 30 | let out = runBuilder $ buildMarkdown path tvs 31 | 32 | liftIO $ if stdout 33 | then putStr out 34 | else withFile fp WriteMode $ flip hPut (toBytes UTF8 out) 35 | where 36 | mkfp = do 37 | fp <- mkPath path 38 | pure $ fromString $ toList $ (filePathToString fp) <> ".md" 39 | 40 | buildMarkdown :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> Builder () 41 | buildMarkdown path tvs = do 42 | emit ("# " <> (filePathToString path)) >> newline 43 | newline 44 | defineTestVector $ snd $ head $ nonEmpty_ tvs 45 | newline 46 | emit "## Test Vectors" >> newline 47 | newline 48 | forM_ tvs $ \(testNumber, tv) -> declareTestVector testNumber tv 49 | 50 | declareTestVector :: Word -> TestVector (Type, Value, Value) -> Builder () 51 | declareTestVector n tv = do 52 | emit ("### Test vector n°" <> show n) >> newline 53 | newline 54 | emit "```" >> newline 55 | mapM_ go (inputs tv) 56 | newline 57 | mapM_ go (outputs tv) 58 | emit "```" >> newline 59 | newline 60 | where 61 | go e = do 62 | let (t, v, _) = entryExtra e 63 | let str = keyToString (entryKey e) <> " = " 64 | emit str 65 | indent (length str) 66 | valueBuilder v t 67 | unindent 68 | newline 69 | 70 | defineTestVector :: TestVector (Type, Value, Value) -> Builder () 71 | defineTestVector tv = do 72 | go "Inputs" (inputs tv) 73 | newline 74 | go "Outputs" (outputs tv) 75 | where 76 | go ty l = do 77 | emit ("## " <> ty) >> newline 78 | newline 79 | emit "```" >> newline 80 | forM_ l $ \e -> do 81 | emit $ (keyToString $ entryKey e) <> " = " <> fromMaybe "No documentation" (entryDoc e) 82 | newline 83 | emit "```" >> newline -------------------------------------------------------------------------------- /src/Inspector/Export/RefFile.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | module Inspector.Export.RefFile 6 | ( testVectorSourceC 7 | , testVectorSinkC 8 | , parseTestVectorFile 9 | , writeTestVectorFile 10 | , run 11 | ) where 12 | 13 | import Foundation 14 | import Foundation.IO 15 | import Foundation.Monad 16 | import Foundation.Conduit 17 | import Foundation.Conduit.Textual 18 | import Foundation.String (Encoding(UTF8)) 19 | 20 | import Foundation.VFS.FilePath 21 | import qualified Foundation.Parser as Parser 22 | 23 | import Inspector.TestVector.Types (Type) 24 | import Inspector.TestVector.Value (Value) 25 | import Inspector.TestVector.TestVector (TestVector, Entry(..), testVectorBuilder, testVectorParser) 26 | import Inspector.Builder 27 | import Inspector.Monad 28 | import Inspector.Parser 29 | 30 | import Data.List (zip) 31 | 32 | run :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> GoldenT () 33 | run path tvs = do 34 | needStdout <- getStdout <$> ask 35 | fp <- mkPath path 36 | 37 | let tvs' = flip fmap tvs $ \(w, tv) -> (w, fromList $ filterEntry <$> toList tv) 38 | 39 | liftIO $ if needStdout 40 | then runConduit $ yields tvs' .| testVectorSinkC .| toBytes UTF8 .| sinkHandle stdout 41 | else withFile fp WriteMode $ \h -> runConduit $ 42 | yields tvs' .| testVectorSinkC .| toBytes UTF8 .| sinkHandle h 43 | where 44 | filterEntry (k, e) = (k,e') 45 | where 46 | e' = Entry 47 | { entryKey = entryKey e 48 | , entryType = entryType e 49 | , entryInput = entryInput e 50 | , entryValue = entryValue e 51 | , entryDoc = entryDoc e 52 | , entryExtra = let (a,_,c) = entryExtra e in (a,c) 53 | } 54 | 55 | writeTestVectorFile :: FilePath -> [TestVector (Type, Value)] -> IO () 56 | writeTestVectorFile fp tvs = withFile fp WriteMode $ \h -> runConduit $ 57 | yields (zip [1..] tvs) .| testVectorSinkC .| toBytes UTF8 .| sinkHandle h 58 | 59 | testVectorSinkC :: Monad m => Conduit (Word, TestVector (Type, Value)) String m () 60 | testVectorSinkC = awaitForever $ \(w, tv) -> do 61 | yield $ "# Test Vector " <> show w <> "\n" 62 | yield $ runBuilder $ testVectorBuilder tv 63 | 64 | parseTestVectorFile :: FilePath -> IO [TestVector ()] 65 | parseTestVectorFile fp = withFile fp ReadMode $ \h -> runConduit $ 66 | sourceHandle h .| fromBytes UTF8 .| testVectorSourceC .| sinkList 67 | 68 | testVectorSourceC :: Monad m => Conduit String (TestVector ()) m () 69 | testVectorSourceC = go defaultS 70 | where 71 | go st = do 72 | mstr <- await 73 | case mstr of 74 | Nothing -> pure () 75 | Just str -> 76 | case parse st (Parser.optional testVectorParser) str of 77 | ParseOk str' (Just r, st') -> leftover str' >> yield r >> go st' 78 | ParseOk str' (Nothing, st') -> error $ show ("not enought (parseDict)" :: String, str', st') 79 | ParseFailed err -> error $ show err 80 | ParseMore more -> go' more 81 | go' more = do 82 | mstr <- await 83 | case mstr of 84 | Nothing -> case more mempty of 85 | ParseOk str' (Just r, st) -> leftover str' >> yield r >> go st 86 | ParseOk _ (Nothing, _) -> pure () -- error $ show ("not enought (more empty)", str', st) 87 | ParseFailed err -> error $ show err 88 | ParseMore _ -> error "ParserMore (more mempty)" 89 | Just str -> case more str of 90 | ParseOk str' (Just r, st) -> leftover str' >> yield r >> go st 91 | ParseOk str' (Nothing, st) -> error $ show ("not enought (more str)" :: String, str, str', st) 92 | ParseFailed err -> error $ show err 93 | ParseMore more' -> go' more' 94 | -------------------------------------------------------------------------------- /src/Inspector/Export/Rust.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | 7 | module Inspector.Export.Rust 8 | ( run 9 | ) where 10 | 11 | import Foundation 12 | import Foundation.Collection (nonEmpty_, KeyedCollection, IndexedCollection, Element) 13 | import qualified Foundation.Collection as F 14 | import Foundation.Monad 15 | import Foundation.Monad.State 16 | import Foundation.IO (withFile, IOMode(..), hPut) 17 | import Foundation.VFS.FilePath 18 | import Foundation.String (upper, toBytes, Encoding(UTF8)) 19 | 20 | import Control.Monad (forM_, forM, when) 21 | 22 | import Inspector.Monad (GoldenT, Config(..), ask, mkPath) 23 | import Inspector.Builder 24 | import Inspector.Export.Types (liftValue) 25 | import Inspector.TestVector.TestVector (TestVector, Entry(..), inputs, outputs) 26 | import Inspector.TestVector.Key (Key, keyToString) 27 | import Inspector.TestVector.Value (Value) 28 | import qualified Inspector.TestVector.Value as Value 29 | import Inspector.TestVector.Types (Type) 30 | import qualified Inspector.TestVector.Types as Type 31 | 32 | run :: FilePath -> [(Word, TestVector (Type, Value, Value))] -> GoldenT () 33 | run path tvs = do 34 | stdout <- getStdout <$> ask 35 | fp <- mkfp 36 | 37 | let out = runBuilder $ buildRust tvs 38 | 39 | liftIO $ if stdout 40 | then putStrLn out 41 | else withFile fp WriteMode $ flip hPut (toBytes UTF8 out) 42 | where 43 | mkfp = do 44 | fp <- mkPath path 45 | pure $ fromString $ toList $ (filePathToString fp) <> ".rs" 46 | 47 | buildRust :: [(Word, TestVector (Type, Value, Value))] -> Builder () 48 | buildRust tvs = do 49 | defineTestVector $ snd $ head $ nonEmpty_ tvs 50 | newline 51 | emit $ "const TEST_VECTORS : [TestVector;" <> show (fromCount (length tvs)) <> "] =" 52 | newline 53 | indent 4 54 | consumeTestVectors tvs 55 | unindent 56 | 57 | consumeTestVectors :: [(Word, TestVector (Type, Value, Value))] -> Builder () 58 | consumeTestVectors l = emit "[ " >> go False l >> emit "];" >> newline 59 | where 60 | go _ [] = pure () 61 | go b ((_, tv):xs) = do 62 | when b $ emit ", " 63 | emit "TestVector {" >> newline >> indent 4 64 | forM_ (inputs tv) go' 65 | forM_ (outputs tv) go' 66 | unindent >> emit " }" >> newline 67 | go True xs 68 | go' ent = do 69 | let str = keyToString (entryKey ent) <> ": " 70 | let (t, v, _) = entryExtra ent 71 | emit str >> indent (length str) >> valueBuilder (entryKey ent) (liftValue t v) >> emit "," >> unindent >> newline 72 | 73 | defineTestVector :: TestVector (Type, Value, Value) -> Builder () 74 | defineTestVector tv = do 75 | let (tvtype, defs) = runConvertion $ convertTestVector tv 76 | 77 | forM_ (toList defs) preDef 78 | defineType tvtype 79 | where 80 | preDef (TypeName tn, ro) = do 81 | emit "#[derive(Debug)]" >> newline 82 | emit ("struct " <> tn <> " {") >> newline 83 | indent 4 84 | forM_ (toList ro) go 85 | unindent >> emit "}" >> newline 86 | where 87 | go (k, rt) = do 88 | let str = keyToString k <> ": " 89 | emit str 90 | indent (length str) 91 | case rt of 92 | CompatibleType t -> emitType t 93 | DefinedType (TypeName n) -> emit n 94 | emit "," 95 | unindent 96 | newline 97 | 98 | defineType :: [(Key, Bool, Maybe String, RustType)] -> Builder () 99 | defineType l = do 100 | emit "#[derive(Debug)]" >> newline 101 | emit "struct TestVector {" >> newline 102 | indent 4 103 | forM_ l go 104 | unindent >> emit "}" >> newline 105 | where 106 | go (k, _, mdoc, rt) = do 107 | let str = keyToString k <> ": " 108 | forM_ mdoc $ \doc -> 109 | emit ("/// " <> doc) >> newline 110 | emit str >> indent (length str) 111 | case rt of 112 | CompatibleType t -> emitType t 113 | DefinedType (TypeName tn) -> emit tn 114 | emit "," >> unindent >> newline 115 | 116 | newtype TypeName = TypeName String 117 | deriving (Show, Eq, Ord, Typeable) 118 | instance IsString TypeName where 119 | fromString str = fromMaybe (error $ "Invalid TypeName" <> show str) (mkTypeName str) 120 | 121 | mkTypeName :: LString -> Maybe TypeName 122 | mkTypeName str = if isOk then Just (TypeName $ fromList str) else Nothing 123 | where 124 | !isOk = and $ check <$> str 125 | check c = c `elem` valids 126 | !valids = ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] <> ['_'] 127 | 128 | data RustType 129 | = CompatibleType Type 130 | | DefinedType TypeName 131 | deriving (Show, Ord, Eq, Typeable) 132 | 133 | newtype RustObject = RustObject [(Key, RustType)] 134 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 135 | 136 | type instance Element RustObject = (Key, RustType) 137 | 138 | instance KeyedCollection RustObject where 139 | type Key RustObject = Key 140 | type Value RustObject = RustType 141 | lookup k = F.lookup k . toList 142 | 143 | instance IsList RustObject where 144 | type Item RustObject = (Key, RustType) 145 | toList (RustObject l) = l 146 | fromList = RustObject 147 | 148 | newtype Convertor a = Convertor (StateT DefinedTypes Identity a) 149 | deriving (Functor, Applicative, Monad) 150 | instance MonadState Convertor where 151 | type State Convertor = DefinedTypes 152 | withState = Convertor . withState 153 | 154 | runConvertion :: Convertor a -> (a, DefinedTypes) 155 | runConvertion (Convertor conv) = runIdentity $ runStateT conv mempty 156 | 157 | isTypeDefined :: RustObject -> Convertor (Maybe TypeName) 158 | isTypeDefined ro = withState $ \dts -> 159 | let r = F.find (\(_, t) -> t == ro) dts 160 | in (fst <$> r, dts) 161 | 162 | mkDefinedType :: Key -> RustObject -> Convertor TypeName 163 | mkDefinedType k ro = withState $ \dts -> 164 | case F.uncons $ keyToString k of 165 | Nothing -> error "mkDefinedType: uncons failed" 166 | Just (x, xs) -> 167 | let tn = TypeName $ (upper $ singleton x) <> xs 168 | in (tn, F.cons (tn, ro) dts) 169 | 170 | convertType :: Key -> Type -> Convertor RustType 171 | convertType key ty = case ty of 172 | Type.Object obj -> do 173 | ro <- RustObject <$> forM (toList obj) traverseFields 174 | mdef <- isTypeDefined ro 175 | case mdef of 176 | Just def -> pure $ DefinedType def 177 | Nothing -> DefinedType <$> mkDefinedType key ro 178 | _ -> pure $ CompatibleType ty 179 | where 180 | traverseFields (k, t) = do 181 | rt <- convertType k t 182 | pure (k, rt) 183 | 184 | convertTestVector :: TestVector (Type, Value, Value) -> Convertor [(Key, Bool, Maybe String, RustType)] 185 | convertTestVector tv = forM (snd <$> toList tv) $ \entry -> do 186 | let (t, _, _) = entryExtra entry 187 | rt <- convertType (entryKey entry) t 188 | pure (entryKey entry, fromMaybe undefined $ entryInput entry, entryDoc entry, rt) 189 | 190 | newtype DefinedTypes = DefinedTypes [(TypeName, RustObject)] 191 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 192 | type instance Element DefinedTypes = (TypeName, RustObject) 193 | instance KeyedCollection DefinedTypes where 194 | type Key DefinedTypes = TypeName 195 | type Value DefinedTypes = RustObject 196 | lookup k = F.lookup k . toList 197 | instance IsList DefinedTypes where 198 | type Item DefinedTypes = (TypeName, RustObject) 199 | toList (DefinedTypes l) = l 200 | fromList = DefinedTypes 201 | 202 | emitType :: Type -> Builder () 203 | emitType t = case t of 204 | Type.Boolean -> emit "bool" 205 | Type.Unsigned8 -> emit "u8" 206 | Type.Unsigned16 -> emit "u16" 207 | Type.Unsigned32 -> emit "u32" 208 | Type.Unsigned64 -> emit "u64" 209 | Type.Signed8 -> emit "i8" 210 | Type.Signed16 -> emit "i16" 211 | Type.Signed32 -> emit "i32" 212 | Type.Signed64 -> emit "i64" 213 | Type.Float32 -> emit "f32" 214 | Type.Float64 -> emit "f64" 215 | Type.String -> emit "&'static str" 216 | Type.Array arr -> emitArray arr 217 | Type.Object _ -> undefined 218 | -- TODO, this is a problem, we need to define objects 219 | -- ahead as they cannot be defined inline of the definition. 220 | 221 | emitArray :: Type.Array -> Builder () 222 | emitArray (Type.SizedArray ty sz) = 223 | emit "&'static [" >> emitType ty >> emit (";" <> show sz <> "]") 224 | emitArray (Type.UnsizedArray ty) = 225 | emit "&'static [" >> emitType ty >> emit "]" 226 | 227 | valueBuilder :: Key -> Value -> Builder () 228 | valueBuilder _ (Value.Boolean b) = emit $ if b then "true" else "false" 229 | valueBuilder _ (Value.Integer i) = emit (show i) 230 | valueBuilder _ (Value.Floating f) = emit (show f) -- TODO 231 | valueBuilder _ (Value.String s) = emit (show s) 232 | valueBuilder k (Value.Array arr) = case toList arr of 233 | [] -> emit "& []" 234 | [x] -> emit "& [ " >> valueBuilder k x >> emit " ]" 235 | (x:xs) -> do 236 | emit "& [ " >> valueBuilder k x 237 | forM_ xs $ \v -> emit ", " >> valueBuilder k v 238 | emit "]" 239 | valueBuilder k (Value.Object obj) = case toList obj of 240 | [] -> emit "{}" 241 | [(k1,v1)] -> do 242 | let str = tn <> " { " <> keyToString k1 <> ": " 243 | emit str >> indent (length str) >> valueBuilder k1 v1 >> unindent >> emit " }" 244 | ((k1,v1):xs) -> do 245 | emit tn 246 | indent (length tn) 247 | let str1 = " { " <> keyToString k1 <> ": " 248 | emit str1 >> indent (length str1) >> valueBuilder k1 v1 >> unindent >> newline 249 | forM_ xs $ \(k', v) -> do 250 | let str = " , " <> keyToString k' <> ": " 251 | emit str >> indent (length str) >> valueBuilder k' v >> unindent >> newline 252 | emit " }" 253 | unindent 254 | where 255 | tn = case F.uncons $ keyToString k of 256 | Nothing -> error "valueBuilder: uncons failed" 257 | Just (a, b) -> (upper $ singleton a) <> b 258 | -------------------------------------------------------------------------------- /src/Inspector/Export/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | 8 | module Inspector.Export.Types 9 | ( OutputType(..) 10 | , Inspectable(..) 11 | , builderToString 12 | , createEntry 13 | , fromEntry 14 | , checkEntryType 15 | , liftValue 16 | , reportError 17 | 18 | , withBoolean 19 | , withInteger 20 | , withDouble 21 | , withString 22 | , withCollection 23 | , withStructure, field 24 | ) where 25 | 26 | import Foundation 27 | import Foundation.String (fromBytesUnsafe) 28 | import Foundation.String.Builder 29 | import qualified Foundation.Collection as F 30 | 31 | import Basement.Block (Block) 32 | import Basement.Nat 33 | import Data.ByteArray (Bytes, convert) 34 | import Data.ByteArray.Encoding 35 | 36 | import Crypto.Hash (Digest, digestFromByteString) 37 | import Crypto.Hash.IO (HashAlgorithm(..)) 38 | import Crypto.MAC.HMAC (HMAC(..)) 39 | 40 | import Control.Applicative (Alternative(..)) 41 | import Control.Monad (mapM) 42 | import Data.Typeable 43 | import GHC.ST (runST) 44 | 45 | import Inspector.TestVector.Types (Type) 46 | import qualified Inspector.TestVector.Types as Type 47 | import Inspector.TestVector.Key (Key, keyToString) 48 | import Inspector.TestVector.Value (Value) 49 | import qualified Inspector.TestVector.Value as Value 50 | import Inspector.TestVector.TestVector (Entry(..)) 51 | 52 | builderToString :: Builder -> String 53 | builderToString a = runST (runUnsafe a) 54 | 55 | data OutputType 56 | = TestVectors 57 | | Markdown 58 | | Rust 59 | deriving (Show, Eq, Ord, Enum, Bounded, Typeable) 60 | 61 | reportError :: String -> Value -> Either String a 62 | reportError desc it = Left $ case it of 63 | Value.Boolean b -> mkError $ "Received a boolean of value " <> show b 64 | Value.Integer i -> mkError $ "Received an integer of value " <> show i 65 | Value.Floating d -> mkError $ "Received an double of value " <> show d 66 | Value.String str -> mkError $ "Received a string of value " <> show str 67 | Value.Array col -> mkError $ "Received a collection of " <> show col 68 | Value.Object str -> mkError $ "Received an object " <> show str 69 | where 70 | mkError :: String -> String 71 | mkError more = "Error when parsing " <> desc <> ". " <> more 72 | 73 | withBoolean :: String -> (Bool -> Either String a) -> Value -> Either String a 74 | withBoolean _ f (Value.Boolean b) = f b 75 | withBoolean t _ r = reportError t r 76 | 77 | withInteger :: String -> (Integer -> Either String a) -> Value -> Either String a 78 | withInteger _ f (Value.Integer i) = f i 79 | withInteger t _ r = reportError t r 80 | 81 | withDouble :: String -> (Double -> Either String a) -> Value -> Either String a 82 | withDouble _ f (Value.Floating i) = f i 83 | withDouble t _ r = reportError t r 84 | 85 | withString :: String -> (String -> Either String a) -> Value -> Either String a 86 | withString _ f (Value.String str) = f str 87 | withString t _ r = reportError t r 88 | 89 | withCollection :: String -> (Value.Array -> Either String a) -> Value -> Either String a 90 | withCollection _ f (Value.Array its) = f its 91 | withCollection t _ r = reportError t r 92 | 93 | withStructure :: String -> (Value.Object -> Either String a) -> Value -> Either String a 94 | withStructure _ f (Value.Object nits) = f nits 95 | withStructure t _ r = reportError t r 96 | 97 | field :: Value.Object -> Key -> Either String Value 98 | field obj k = case F.lookup k obj of 99 | Nothing -> reportError ("missing field: " <> keyToString k) (Value.Object obj) 100 | Just r -> pure r 101 | 102 | class Inspectable a where 103 | documentation :: Proxy a -> String 104 | 105 | -- | this is the type of export, one of the type, close to representation 106 | -- that is understood by the different `OutputType` 107 | -- 108 | exportType :: Proxy a -> Type 109 | 110 | -- | reconstruct the object from the given value 111 | parser :: Value -> Either String a 112 | 113 | -- | seralise the object into a value 114 | builder :: a -> Value 115 | 116 | createEntry :: forall a . Inspectable a => Key -> a -> Bool -> Entry (Type, Value) 117 | createEntry k v isInput = Entry 118 | { entryKey = k 119 | , entryType = t 120 | , entryValue = v' 121 | , entryInput = Just isInput 122 | , entryDoc = Just (documentation (Proxy @a)) 123 | , entryExtra = (t, v') 124 | } 125 | where 126 | t = exportType (Proxy @a) 127 | v' = builder v 128 | 129 | checkEntryType :: Inspectable a => Proxy a -> Entry () -> Bool -> Entry (Type, Value) 130 | checkEntryType p e isInput = Entry 131 | { entryKey = entryKey e 132 | , entryType = entryType e 133 | , entryValue = entryValue e 134 | , entryInput = Just isInput 135 | , entryDoc = Just (documentation p) 136 | , entryExtra = (t, liftValue t (entryValue e)) 137 | } 138 | where 139 | t = exportType p 140 | 141 | fromEntry :: Inspectable a 142 | => Proxy a 143 | -> Entry (Type, Value) 144 | -> Either String a 145 | fromEntry _ e = first show $ parser (snd $ entryExtra e) 146 | 147 | liftValue :: Type -> Value -> Value 148 | liftValue t v 149 | | Type.isByteArray t = toByteArray v 150 | | otherwise = case (t, v) of 151 | (Type.Array arrTy, Value.Array arr) -> Value.Array $ liftArray arrTy arr 152 | (Type.Object objTy, Value.Object obj) -> Value.Object $ liftObject objTy obj 153 | _ -> v 154 | where 155 | liftArray (Type.SizedArray t' _) arr = fromList $ liftValue t' <$> toList arr 156 | liftArray (Type.UnsizedArray t') arr = fromList $ liftValue t' <$> toList arr 157 | 158 | liftObject objdef obj = fromList $ linktype (toList objdef) obj 159 | where 160 | linktype [] _ = [] 161 | linktype ((k,t'):ts) vs = case F.lookup k vs of 162 | Nothing -> error $ "undefined value for key: " <> keyToString k 163 | Just v' -> (k, liftValue t' v') : linktype ts vs 164 | 165 | toByteArray :: Value -> Value 166 | toByteArray (Value.String str) 167 | | and (isHex <$> toList str) = builder $ toList (either (error . fromList) id (convertFromBase Base16 str) :: Block Word8) 168 | | otherwise = builder (convert str :: Bytes) 169 | toByteArray v = v 170 | 171 | isHex :: Char -> Bool 172 | isHex c = c `elem` (['a'..'f'] <> ['A'..'F'] <> ['0'..'9']) 173 | 174 | instance Inspectable Bool where 175 | documentation _ = "Boolean value, either true or false." 176 | exportType _ = Type.Boolean 177 | parser = withBoolean "Bool" pure 178 | builder = Value.Boolean 179 | instance Inspectable Int8 where 180 | documentation _ = "8 bits signed integer." 181 | exportType _ = Type.Signed8 182 | parser = withInteger "Int8" (pure . fromInteger) 183 | builder = Value.Integer . toInteger 184 | instance Inspectable Int16 where 185 | documentation _ = "16 bits signed integer." 186 | exportType _ = Type.Signed16 187 | parser = withInteger "Int16" (pure . fromInteger) 188 | builder = Value.Integer . toInteger 189 | instance Inspectable Int32 where 190 | documentation _ = "32 bits signed integer." 191 | exportType _ = Type.Signed32 192 | parser = withInteger "Int32" (pure . fromInteger) 193 | builder = Value.Integer . toInteger 194 | instance Inspectable Int64 where 195 | documentation _ = "64 bits signed integer." 196 | exportType _ = Type.Signed64 197 | parser = withInteger "Int64" (pure . fromInteger) 198 | builder = Value.Integer . toInteger 199 | instance Inspectable Int where 200 | documentation _ = "signed integer." 201 | exportType _ = Type.Signed64 202 | parser = withInteger "Int" (pure . fromInteger) 203 | builder = Value.Integer . toInteger 204 | instance Inspectable Integer where 205 | documentation _ = "signed unbounded integer" 206 | exportType _ = Type.Signed64 207 | parser = withInteger "Integer" (pure . fromInteger) 208 | builder = Value.Integer 209 | instance Inspectable Word8 where 210 | documentation _ = "8 bits unsigned integer." 211 | exportType _ = Type.Unsigned8 212 | parser = withInteger "Word8" (pure . fromInteger) 213 | builder = Value.Integer . toInteger 214 | instance Inspectable Word16 where 215 | documentation _ = "16 bits unsigned integer." 216 | exportType _ = Type.Unsigned16 217 | parser = withInteger "Word16" (pure . fromInteger) 218 | builder = Value.Integer . toInteger 219 | instance Inspectable Word32 where 220 | documentation _ = "32 bits unsigned integer." 221 | exportType _ = Type.Unsigned32 222 | parser = withInteger "Word32" (pure . fromInteger) 223 | builder = Value.Integer . toInteger 224 | instance Inspectable Word64 where 225 | documentation _ = "64 bits unsigned integer." 226 | exportType _ = Type.Unsigned64 227 | parser = withInteger "Word64" (pure . fromInteger) 228 | builder = Value.Integer . toInteger 229 | instance Inspectable Word where 230 | documentation _ = "unsigned integer." 231 | exportType _ = Type.Unsigned64 232 | parser = withInteger "Word" (pure . fromInteger) 233 | builder = Value.Integer . toInteger 234 | instance Inspectable Double where 235 | documentation _ = "64 bits float." 236 | exportType _ = Type.Float64 237 | parser = withDouble "Double" pure 238 | builder = Value.Floating 239 | instance Inspectable String where 240 | documentation _ = "UTF8 string" 241 | exportType _ = Type.String 242 | parser = withString "String" pure 243 | builder = Value.String 244 | instance Inspectable (Block Word8) where 245 | documentation _ = "array of bytes" 246 | exportType _ = Type.Array (Type.UnsizedArray Type.Unsigned8) 247 | parser it = withCollection "Block Word8" (fmap fromList . mapM parser . toList) it 248 | <|> withString "Block Word8" (first fromList . convertFromBase Base16) it 249 | -- builder blck = ITCollection $ builder <$> toList blck 250 | builder = Value.String . fromBytesUnsafe . convertToBase Base16 251 | instance (Typeable a, Inspectable a) => Inspectable [a] where 252 | documentation _ = "collection of " <> documentation (Proxy @a) 253 | exportType _ = Type.Array (Type.UnsizedArray (exportType (Proxy @a))) 254 | parser = withCollection ("["<>show (typeRep (Proxy @a))<>"]") $ fmap fromList . mapM parser . toList 255 | builder l = Value.Array $ fromList $ builder <$> l 256 | instance (HashAlgorithm hash, KnownNat (HashDigestSize hash)) => Inspectable (Digest hash) where 257 | documentation _ = "bytes representing a digest of " <> show size <> " bytes." 258 | where 259 | size = natVal $ Proxy @(HashDigestSize hash) 260 | exportType _ = Type.Array (Type.SizedArray Type.Unsigned8 size) 261 | where 262 | size = fromInteger $ natVal $ Proxy @(HashDigestSize hash) 263 | parser t = do 264 | blk <- parser t :: Either String (Block Word8) 265 | case digestFromByteString blk of 266 | Nothing -> reportError "invalid digest" t 267 | Just v -> pure v 268 | builder t = builder (convert t :: Block Word8) 269 | instance Inspectable Bytes where 270 | documentation _ = "array of bytes" 271 | exportType _ = exportType (Proxy @(Block Word8)) 272 | parser t = convert <$> (parser t :: Either String (Block Word8)) 273 | builder t = builder (convert t :: Block Word8) 274 | instance (HashAlgorithm hash, KnownNat (HashDigestSize hash)) => Inspectable (HMAC hash) where 275 | documentation _ = "bytes representing a HMAC digest of " <> show size <> " bytes." 276 | where 277 | size = natVal $ Proxy @(HashDigestSize hash) 278 | exportType _ = exportType (Proxy @(Digest hash)) 279 | parser t = HMAC <$> parser t 280 | builder t = builder (convert t :: Block Word8) 281 | 282 | -- ------------------------------------------------------------------------- -- 283 | 284 | instance Alternative (Either String) where 285 | empty = undefined 286 | (<|>) (Left _) r = r 287 | (<|>) l _ = l 288 | -------------------------------------------------------------------------------- /src/Inspector/Method.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE Rank2Types #-} 9 | 10 | module Inspector.Method 11 | ( (:>) 12 | , Payload 13 | , HasPath 14 | , getPath 15 | , HasMethod 16 | , Method 17 | , method 18 | , PathParameter 19 | , IsValue 20 | , Golden 21 | ) where 22 | 23 | import Foundation 24 | import Foundation.VFS.FilePath 25 | import Foundation.Check 26 | 27 | import Control.Monad (void) 28 | import GHC.TypeLits 29 | import Data.Typeable 30 | 31 | import Inspector.Monad 32 | import Inspector.Export.Types 33 | import Inspector.TestVector.Key (symbolKey_) 34 | import Inspector.TestVector.Types (Type) 35 | import Inspector.TestVector.Value (Value) 36 | import Inspector.TestVector.TestVector (TestVector, query, Entry(..)) 37 | 38 | 39 | -- | Alias Constraint Type for IsValue type 40 | type IsValue value = (Inspectable value, Typeable value) 41 | 42 | -- | Alias Constraint type for golden test 43 | type Golden golden = (HasMethod golden, HasPath golden) 44 | 45 | 46 | data (i :: k) :> o 47 | deriving (Typeable) 48 | infixr 9 :> 49 | 50 | -- | Type level alias to describe what to retrive from the test vector 51 | -- 52 | -- a Test vector can be as follow: 53 | -- 54 | -- @ 55 | -- TestVector 56 | -- key = value 57 | -- @ 58 | -- 59 | data Payload (key :: Symbol) value 60 | deriving (Typeable) 61 | 62 | data PathParameter (key :: Symbol) (n :: Nat) 63 | 64 | -- | type class to retrieve the Path of a given Golden Spec 65 | -- 66 | -- @ 67 | -- import Crypto.Hash (hash, Digest, SHA1) 68 | -- 69 | -- type GoldenSHA1 = "hash" :> "SHA1" :> Payload "payload" String :> Payload "hash" (Digest SHA1) 70 | -- getPath (Proxy @GoldenSHA1) = ["hash", "SHA1"] 71 | -- @ 72 | -- 73 | -- This will help us know where to find the test vectors 74 | -- 75 | -- The path discoverability in the type stop at the first occurence of a 'Payload' 76 | -- 77 | class HasPath path where 78 | getPath :: Proxy path -> [FileName] 79 | 80 | instance {-# OVERLAPPABLE #-} (KnownSymbol path, HasPath sub) => HasPath (path :> sub) where 81 | getPath _ = fromString (symbolVal (Proxy @path)) : getPath (Proxy @sub) 82 | instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol path, HasPath sub) => HasPath (PathParameter path n :> sub) where 83 | getPath _ = fromString (toList $ path <> n) : getPath (Proxy @sub) 84 | where 85 | n = show (natVal (Proxy @n)) 86 | path = fromString (symbolVal (Proxy @path)) 87 | instance {-# OVERLAPPING #-} KnownSymbol path => HasPath (path :> Payload k v :> sub) where 88 | getPath _ = [fromString (symbolVal (Proxy @path))] 89 | instance {-# OVERLAPPING #-} (KnownNat n, KnownSymbol path) => HasPath (PathParameter path n :> Payload k v :> sub) where 90 | getPath _ = [fromString (toList $ path <> n)] 91 | where 92 | n = show (natVal (Proxy @n)) 93 | path = fromString (symbolVal (Proxy @path)) 94 | 95 | -- | Type class to retrieve the parameter of the given method and to call the 96 | -- method on the fly 97 | -- 98 | class HasMethod method where 99 | type Method method 100 | 101 | method :: forall c b m . Monad m 102 | => Proxy method 103 | -> Method method 104 | -> (forall a k . (IsValue a, KnownSymbol k) => Proxy k -> Entry (Type, Value, a) -> GoldenMT c m b) 105 | -> TestVector () 106 | -> GoldenMT c m b 107 | 108 | instance (KnownSymbol path, HasMethod sub) => HasMethod (path :> sub) where 109 | type Method (path :> sub) = Method sub 110 | method _ = method (Proxy @sub) 111 | 112 | instance (KnownSymbol path, KnownNat n, HasMethod sub) => HasMethod (PathParameter path n :> sub) where 113 | type Method (PathParameter path n :> sub) = Method sub 114 | method _ = method (Proxy @sub) 115 | 116 | instance (KnownSymbol key, HasMethod sub, IsValue value, Arbitrary value) => HasMethod (Payload key value :> sub) where 117 | type Method (Payload key value :> sub) = value -> Method sub 118 | 119 | method _ action f dict = do 120 | mvalue <- retrieve @key @value Proxy True dict 121 | value <- case mvalue of 122 | Nothing -> error $ "missing key: " <> fromString (symbolVal (Proxy @key)) 123 | Just value -> pure value 124 | void $ f (Proxy @key) value 125 | let (_, _, v) = entryExtra value 126 | method (Proxy @sub) (action v) f dict 127 | 128 | instance (KnownSymbol key, IsValue value) => HasMethod (Payload key value) where 129 | type Method (Payload key value) = value 130 | 131 | method _ action f dict = do 132 | ma <- retrieve @key @value Proxy False dict 133 | f (Proxy @key) (finalEntry (Proxy @key) ma action) 134 | 135 | finalEntry :: forall a k . (Inspectable a, KnownSymbol k) 136 | => Proxy k -> Maybe (Entry (Type, Value, a)) -> a -> Entry (Type, Value, a) 137 | finalEntry p Nothing a = 138 | let e = createEntry (symbolKey_ p) a False 139 | in e { entryExtra = (entryType e, entryValue e, a) } 140 | finalEntry _ (Just e) a = 141 | let (t, v, _) = entryExtra e 142 | in e { entryExtra = (t, v, a), entryInput = Just False } 143 | 144 | instance ( KnownSymbol k1, IsValue v1 145 | , KnownSymbol k2, IsValue v2 146 | ) 147 | => HasMethod ( Payload k1 v1 148 | , Payload k2 v2 149 | ) 150 | where 151 | type Method ( Payload k1 v1 152 | , Payload k2 v2 153 | ) = (v1, v2) 154 | 155 | method _ action f dict = do 156 | mv1 <- retrieve @k1 @v1 Proxy False dict 157 | mv2 <- retrieve @k2 @v2 Proxy False dict 158 | let (v1, v2) = action 159 | let e1 = finalEntry (Proxy @k1) mv1 v1 160 | let e2 = finalEntry (Proxy @k2) mv2 v2 161 | void $ f (Proxy @k1) e1 162 | f (Proxy @k2) e2 163 | 164 | instance ( KnownSymbol k1, IsValue v1 165 | , KnownSymbol k2, IsValue v2 166 | , KnownSymbol k3, IsValue v3 167 | ) 168 | => HasMethod ( Payload k1 v1 169 | , Payload k2 v2 170 | , Payload k3 v3 171 | ) 172 | where 173 | type Method ( Payload k1 v1 174 | , Payload k2 v2 175 | , Payload k3 v3 176 | ) = (v1, v2, v3) 177 | 178 | method _ action f dict = do 179 | mv1 <- retrieve @k1 @v1 Proxy False dict 180 | mv2 <- retrieve @k2 @v2 Proxy False dict 181 | mv3 <- retrieve @k3 @v3 Proxy False dict 182 | let (v1, v2, v3) = action 183 | let e1 = finalEntry (Proxy @k1) mv1 v1 184 | let e2 = finalEntry (Proxy @k2) mv2 v2 185 | let e3 = finalEntry (Proxy @k3) mv3 v3 186 | void $ f (Proxy @k1) e1 187 | void $ f (Proxy @k2) e2 188 | f (Proxy @k3) e3 189 | 190 | instance ( KnownSymbol k1, IsValue v1 191 | , KnownSymbol k2, IsValue v2 192 | , KnownSymbol k3, IsValue v3 193 | , KnownSymbol k4, IsValue v4 194 | ) 195 | => HasMethod ( Payload k1 v1 196 | , Payload k2 v2 197 | , Payload k3 v3 198 | , Payload k4 v4 199 | ) 200 | where 201 | type Method ( Payload k1 v1 202 | , Payload k2 v2 203 | , Payload k3 v3 204 | , Payload k4 v4 205 | ) = (v1, v2, v3, v4) 206 | 207 | method _ action f dict = do 208 | mv1 <- retrieve @k1 @v1 Proxy False dict 209 | mv2 <- retrieve @k2 @v2 Proxy False dict 210 | mv3 <- retrieve @k3 @v3 Proxy False dict 211 | mv4 <- retrieve @k4 @v4 Proxy False dict 212 | let (v1, v2, v3, v4) = action 213 | let e1 = finalEntry (Proxy @k1) mv1 v1 214 | let e2 = finalEntry (Proxy @k2) mv2 v2 215 | let e3 = finalEntry (Proxy @k3) mv3 v3 216 | let e4 = finalEntry (Proxy @k4) mv4 v4 217 | void $ f (Proxy @k1) e1 218 | void $ f (Proxy @k2) e2 219 | void $ f (Proxy @k3) e3 220 | f (Proxy @k4) e4 221 | 222 | instance ( KnownSymbol k1, IsValue v1 223 | , KnownSymbol k2, IsValue v2 224 | , KnownSymbol k3, IsValue v3 225 | , KnownSymbol k4, IsValue v4 226 | , KnownSymbol k5, IsValue v5 227 | ) 228 | => HasMethod ( Payload k1 v1 229 | , Payload k2 v2 230 | , Payload k3 v3 231 | , Payload k4 v4 232 | , Payload k5 v5 233 | ) 234 | where 235 | type Method ( Payload k1 v1 236 | , Payload k2 v2 237 | , Payload k3 v3 238 | , Payload k4 v4 239 | , Payload k5 v5 240 | ) = (v1, v2, v3, v4, v5) 241 | 242 | method _ action f dict = do 243 | mv1 <- retrieve @k1 @v1 Proxy False dict 244 | mv2 <- retrieve @k2 @v2 Proxy False dict 245 | mv3 <- retrieve @k3 @v3 Proxy False dict 246 | mv4 <- retrieve @k4 @v4 Proxy False dict 247 | mv5 <- retrieve @k5 @v5 Proxy False dict 248 | let (v1, v2, v3, v4, v5) = action 249 | let e1 = finalEntry (Proxy @k1) mv1 v1 250 | let e2 = finalEntry (Proxy @k2) mv2 v2 251 | let e3 = finalEntry (Proxy @k3) mv3 v3 252 | let e4 = finalEntry (Proxy @k4) mv4 v4 253 | let e5 = finalEntry (Proxy @k5) mv5 v5 254 | void $ f (Proxy @k1) e1 255 | void $ f (Proxy @k2) e2 256 | void $ f (Proxy @k3) e3 257 | void $ f (Proxy @k4) e4 258 | f (Proxy @k5) e5 259 | 260 | instance ( KnownSymbol k1, IsValue v1 261 | , KnownSymbol k2, IsValue v2 262 | , KnownSymbol k3, IsValue v3 263 | , KnownSymbol k4, IsValue v4 264 | , KnownSymbol k5, IsValue v5 265 | , KnownSymbol k6, IsValue v6 266 | ) 267 | => HasMethod ( Payload k1 v1 268 | , Payload k2 v2 269 | , Payload k3 v3 270 | , Payload k4 v4 271 | , Payload k5 v5 272 | , Payload k6 v6 273 | ) 274 | where 275 | type Method ( Payload k1 v1 276 | , Payload k2 v2 277 | , Payload k3 v3 278 | , Payload k4 v4 279 | , Payload k5 v5 280 | , Payload k6 v6 281 | ) = (v1, v2, v3, v4, v5, v6) 282 | 283 | method _ action f dict = do 284 | mv1 <- retrieve @k1 @v1 Proxy False dict 285 | mv2 <- retrieve @k2 @v2 Proxy False dict 286 | mv3 <- retrieve @k3 @v3 Proxy False dict 287 | mv4 <- retrieve @k4 @v4 Proxy False dict 288 | mv5 <- retrieve @k5 @v5 Proxy False dict 289 | mv6 <- retrieve @k6 @v6 Proxy False dict 290 | let (v1, v2, v3, v4, v5, v6) = action 291 | let e1 = finalEntry (Proxy @k1) mv1 v1 292 | let e2 = finalEntry (Proxy @k2) mv2 v2 293 | let e3 = finalEntry (Proxy @k3) mv3 v3 294 | let e4 = finalEntry (Proxy @k4) mv4 v4 295 | let e5 = finalEntry (Proxy @k5) mv5 v5 296 | let e6 = finalEntry (Proxy @k6) mv6 v6 297 | void $ f (Proxy @k1) e1 298 | void $ f (Proxy @k2) e2 299 | void $ f (Proxy @k3) e3 300 | void $ f (Proxy @k4) e4 301 | void $ f (Proxy @k5) e5 302 | f (Proxy @k6) e6 303 | 304 | -- helper method to retrieve a value from a dictionary 305 | retrieve :: forall key value c m 306 | . ( IsValue value 307 | , Monad m 308 | , KnownSymbol key 309 | ) 310 | => Proxy (key :: Symbol) 311 | -> Bool 312 | -> TestVector () 313 | -> GoldenMT c m (Maybe (Entry (Type, Value, value))) 314 | retrieve pk isInput dict = case query pk dict of 315 | Nothing -> pure Nothing 316 | Just e -> 317 | let en = checkEntryType (Proxy @value) e isInput 318 | in case parser @value (snd $ entryExtra en) of 319 | Left err -> error $ err <> "\n While decoding " <> k <> " of type " <> show ty 320 | Right v -> pure $ Just $ Entry 321 | { entryKey = entryKey en 322 | , entryType = entryType en 323 | , entryValue = entryValue en 324 | , entryInput = entryInput en 325 | , entryDoc = entryDoc en 326 | , entryExtra = (fst (entryExtra en), snd (entryExtra en), v) 327 | } 328 | where 329 | k = show $ symbolVal pk 330 | ty = show $ typeRep (Proxy @value) 331 | -------------------------------------------------------------------------------- /src/Inspector/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Inspector.Monad 4 | ( GoldenMT 5 | , Config(..) 6 | , Mode(..) 7 | , OutputType(..) 8 | , runGolden 9 | , runGolden' 10 | , ask 11 | , lift 12 | , withState 13 | , exec 14 | , mkPath 15 | 16 | , GoldenM 17 | , store 18 | 19 | , GoldenT 20 | , Metadata(..) 21 | , summary 22 | , getMetadata 23 | , goldenTFail 24 | , goldenTFailed 25 | , Builder 26 | ) where 27 | 28 | import Foundation hiding ((<>)) 29 | import Foundation.Monad 30 | import Foundation.Monad.Reader 31 | import Foundation.Monad.State 32 | import Foundation.VFS 33 | import Foundation.String.Builder 34 | 35 | import Basement.Compat.Semigroup 36 | 37 | import GHC.TypeLits 38 | 39 | import Inspector.Export.Types 40 | import Inspector.TestVector.TestVector (TestVector(..), Entry(..), add) 41 | import Inspector.TestVector.Types (Type) 42 | import Inspector.TestVector.Value (Value) 43 | 44 | data Mode = Generate !OutputType 45 | | GoldenTest 46 | deriving (Show, Eq, Ord, Typeable) 47 | 48 | data Config = Config 49 | { getMode :: !Mode 50 | , getRoot :: !FilePath 51 | , getStdout :: !Bool 52 | } 53 | deriving (Show, Eq, Typeable) 54 | 55 | newtype GoldenMT st m a = GoldenM { runGoldenM_ :: StateT st (ReaderT Config m) a } 56 | deriving (Typeable, Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadIO) 57 | instance MonadTrans (GoldenMT st) where 58 | lift = GoldenM . lift . lift 59 | instance Monad m => MonadState (GoldenMT st m) where 60 | type State (GoldenMT st m) = st 61 | withState = GoldenM . withState 62 | instance Monad m => MonadReader (GoldenMT st m) where 63 | type ReaderContext (GoldenMT st m) = Config 64 | ask = GoldenM $ lift ask 65 | 66 | runGolden :: Functor m => Config -> st -> GoldenMT st m a -> m (a, st) 67 | runGolden cfg st golden = runReaderT (runStateT (runGoldenM_ golden) st) cfg 68 | 69 | runGolden' :: (Monoid st, Functor m) => Config -> GoldenMT st m a -> m (a, st) 70 | runGolden' cfg = runGolden cfg mempty 71 | 72 | exec :: (Monoid st, Monad m) => GoldenMT st m a -> GoldenMT st' m st 73 | exec golden = do 74 | cfg <- ask 75 | snd <$> lift (runGolden' cfg golden) 76 | 77 | mkPath :: Monad m => FilePath -> GoldenMT st m FilePath 78 | mkPath target = do 79 | (p, root, _) <- splitPath . getRoot <$> ask 80 | let (_, t, _) = splitPath target 81 | pure $ buildPath (p, root <> t, ()) 82 | 83 | data Metadata = Metadata 84 | { metaDescription :: !String 85 | , goldenTestFailed :: !Bool 86 | } 87 | deriving (Show, Eq, Typeable) 88 | instance Semigroup Metadata where 89 | (<>) (Metadata d1 t1) (Metadata d2 t2) = Metadata (d1 <> d2) (t1 && t2) 90 | 91 | instance Monoid Metadata where 92 | mempty = Metadata mempty False 93 | 94 | -- | Monad responsible for controlling the execution flow of the test vectors 95 | -- 96 | type GoldenT = GoldenMT Metadata IO 97 | 98 | summary :: String -> GoldenT () 99 | summary b = withState $ \st -> ((), st { metaDescription = b }) 100 | 101 | goldenTFail :: GoldenT () 102 | goldenTFail = withState $ \st -> ((), st {goldenTestFailed = True}) 103 | 104 | goldenTFailed :: GoldenT Bool 105 | goldenTFailed = goldenTestFailed <$> getMetadata 106 | 107 | getMetadata :: GoldenT Metadata 108 | getMetadata = withState $ \st -> (st, st) 109 | 110 | -- | Monad for a running golden test 111 | -- 112 | type GoldenM = GoldenMT (TestVector (Type, Value, Value)) IO 113 | 114 | store :: (KnownSymbol key, Inspectable value) 115 | => Proxy (key :: Symbol) -> Entry (Type, Value, value) -> GoldenM () 116 | store pk ent = withState $ \dict -> 117 | ((), add pk ent' dict) 118 | where 119 | (t, _, a) = entryExtra ent 120 | ent' = Entry 121 | { entryType = entryType ent 122 | , entryValue = entryValue ent 123 | , entryKey = entryKey ent 124 | , entryInput = entryInput ent 125 | , entryDoc = entryDoc ent 126 | , entryExtra = (t, entryValue ent, builder a) 127 | } 128 | -------------------------------------------------------------------------------- /src/Inspector/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Inspector.Parser 4 | ( Parser 5 | , S, lineParsed 6 | , reportError 7 | , ParseError(..) 8 | , Result(..) 9 | , parse 10 | , defaultS 11 | , parseOnly 12 | 13 | , Parser.optional 14 | , elements 15 | , element 16 | , skip 17 | , takeWhile_ 18 | , satisfy 19 | , many 20 | , some 21 | 22 | , whiteSpace 23 | , newline 24 | , whiteSpaces 25 | , whiteSpacesAndNewLines 26 | , comment 27 | ) where 28 | 29 | import Foundation 30 | import Foundation.Parser (ParseError(..), Result(..)) 31 | import qualified Foundation.Parser as Parser 32 | import Foundation.Monad 33 | import Foundation.Monad.State 34 | 35 | import Control.Applicative (Alternative(..)) 36 | 37 | newtype S = S { lineParsed :: Word } 38 | deriving (Typeable, Show, Eq, Ord) 39 | 40 | defaultS :: S 41 | defaultS = S 0 42 | 43 | parse :: S -> Parser a -> String -> Result String (a, S) 44 | parse st (Parser s) = Parser.parse (runStateT s st) 45 | 46 | parseOnly :: Parser a -> String -> Either (ParseError String) (a, S) 47 | parseOnly (Parser s) = Parser.parseOnly (runStateT s defaultS) 48 | 49 | newtype Parser a = Parser (StateT S (Parser.Parser String) a) 50 | deriving (Functor, Applicative, Monad) 51 | instance Alternative Parser where 52 | empty = Parser $ lift empty 53 | (<|>) (Parser s1) (Parser s2) = Parser $ do 54 | st <- withState $ \st -> (st, st) 55 | r <- lift $ runStateT s1 st <|> runStateT s2 st 56 | withState $ const r 57 | 58 | reportError :: ParseError String -> Parser a 59 | reportError err = do 60 | _lp <- Parser $ withState $ \st -> (lineParsed st, st) 61 | Parser $ lift $ Parser.reportError err 62 | 63 | 64 | elements :: String -> Parser () 65 | elements = Parser . lift . Parser.elements 66 | 67 | element :: Char -> Parser () 68 | element = Parser . lift . Parser.element 69 | 70 | skip :: CountOf Char -> Parser () 71 | skip = Parser . lift . Parser.skip 72 | 73 | takeWhile_ :: (Char -> Bool) -> Parser String 74 | takeWhile_ = Parser . lift . Parser.takeWhile 75 | 76 | satisfy :: (Char -> Bool) -> Parser Char 77 | satisfy = Parser . lift . Parser.satisfy_ 78 | 79 | whiteSpace :: Parser () 80 | whiteSpace = element ' ' <|> element '\t' 81 | 82 | newline :: Parser () 83 | newline = do 84 | element '\n' 85 | Parser $ withState $ \st -> ((), st { lineParsed = succ (lineParsed st) }) 86 | 87 | comment :: Parser () 88 | comment = element '#' *> takeWhile_ ('\n' /=) *> newline 89 | 90 | whiteSpaces, whiteSpacesAndNewLines :: Parser () 91 | whiteSpaces = many whiteSpace >> pure () 92 | whiteSpacesAndNewLines = many (whiteSpace <|> newline) >> pure () 93 | -------------------------------------------------------------------------------- /src/Inspector/Report.hs: -------------------------------------------------------------------------------- 1 | module Inspector.Report 2 | ( TestReport (..) 3 | , Report (..) 4 | , prettyC 5 | ) where 6 | 7 | import Foundation 8 | import Foundation.Conduit 9 | import Foundation.VFS 10 | import Control.Monad (forM_) 11 | 12 | import Basement.Bounded 13 | import qualified Basement.Terminal.ANSI as ANSI 14 | 15 | import Inspector.TestVector.TestVector (TestVector, Entry) 16 | import Inspector.TestVector.Value (Value) 17 | import Inspector.TestVector.Key (Key) 18 | 19 | data TestReport 20 | = Success | Failure Word [Diff] 21 | deriving (Show) 22 | 23 | data Report = Report 24 | { reportPath :: !FilePath 25 | , reportTests :: ![TestReport] 26 | } 27 | deriving (Show) 28 | 29 | successes :: [TestReport] -> Word 30 | successes = foldr count 0 31 | where 32 | count Success = (+) 1 33 | count _ = id 34 | 35 | failures :: [TestReport] -> [(Word, [Diff])] 36 | failures = foldr f [] 37 | where 38 | f Success = id 39 | f (Failure x d) = (:) (x,d) 40 | 41 | total :: [TestReport] -> Word 42 | total = foldr (\_ acc -> acc + 1) 0 43 | 44 | prettyC :: Monad m => Conduit Report String m () 45 | prettyC = awaitForever $ \(Report path tests) -> do 46 | let failed = failures tests 47 | yield $ if null failed 48 | then green <> " ✓ " <> reset 49 | else red <> " ✗ " <> reset 50 | yield $ filePathToString path <> ": " 51 | <> show (successes tests) <> "/" <> show (total tests) <> "\n" 52 | 53 | forM_ (failures tests) $ \(i,diffs) -> do 54 | yield $ " * TestVector " <> show i <> "\n" 55 | forM_ diffs $ \x -> case x of 56 | Missing k v -> yield $ "- " <> k <> " = " <> show v <> "\n" 57 | Added k v -> yield $ "+ " <> k <> " = " <> show v <> "\n" 58 | Diff k (v1, v2) -> yields 59 | [ "- " <> k <> " = " <> show v1 <> "\n" 60 | , "+ " <> k <> " = " <> show v2 <> "\n" 61 | ] 62 | 63 | reset, green, red :: ANSI.Escape 64 | reset = ANSI.sgrReset 65 | green = ANSI.sgrForeground (zn64 2) True 66 | red = ANSI.sgrForeground (zn64 1) True 67 | -------------------------------------------------------------------------------- /src/Inspector/TestVector/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Inspector.TestVector.Key 7 | ( Key 8 | , keyToString 9 | , mkKey 10 | , symbolKey 11 | , symbolKey_ 12 | , keyParser 13 | ) where 14 | 15 | import Foundation 16 | import Foundation.Check (Arbitrary(..), between, frequency, elements) 17 | import Foundation.Collection (nonEmpty_) 18 | 19 | import Basement.NormalForm () 20 | import GHC.TypeLits 21 | import Data.Typeable (typeRep) 22 | 23 | import Control.Monad (replicateM) 24 | 25 | import Inspector.Parser (Parser) 26 | import qualified Inspector.Parser as Parser 27 | 28 | -- | Key 29 | -- 30 | -- Valid key are of the form: `[a-z][a-zA-Z0-9_]*` 31 | -- 32 | newtype Key = Key { keyToString :: String } 33 | deriving (Show, Eq, Ord, Typeable, NormalForm) 34 | instance IsString Key where 35 | fromString str = maybe (error $ "invalid Key... " <> show str) id $ mkKey $ fromList str 36 | 37 | instance Arbitrary Key where 38 | arbitrary = do 39 | x <- elements $ nonEmpty_ ['a'..'z'] 40 | len <- fromIntegral <$> between (0, 7) 41 | xs <- replicateM len validCharGen 42 | pure $ Key . fromList $ x : xs 43 | where 44 | validCharGen = frequency $ nonEmpty_ 45 | [ (65, elements $ nonEmpty_ ['a'..'z']) 46 | , (20, elements $ nonEmpty_ ['A'..'Z']) 47 | , (10, elements $ nonEmpty_ ['0'..'9']) 48 | , ( 5, pure '_') 49 | ] 50 | 51 | symbolKey_ :: forall key. KnownSymbol key => Proxy key -> Key 52 | symbolKey_ proxy = fromMaybe errorMsg $ symbolKey proxy 53 | where 54 | errorMsg = error $ "Invalid Symbol Key <> " <> show (typeRep proxy) 55 | 56 | symbolKey :: forall key. KnownSymbol key => Proxy key -> Maybe Key 57 | symbolKey proxy = mkKey str 58 | where 59 | str = fromList $ symbolVal proxy 60 | 61 | -- | smart constructor, check the key is valid before constructing it 62 | -- 63 | -- this function use `keyParser` 64 | mkKey :: String -> Maybe Key 65 | mkKey str = case Parser.parseOnly keyParser str of 66 | Left _ -> Nothing 67 | Right (k, _) -> Just k 68 | 69 | -- | key parser 70 | -- 71 | keyParser :: Parser Key 72 | keyParser = do 73 | x <- Parser.satisfy (`elem` validStartChar) 74 | xs <- Parser.takeWhile_ (`elem` validChar) 75 | pure $ Key $ cons x xs 76 | 77 | validStartChar :: [Char] 78 | validStartChar = ['a'..'z'] 79 | 80 | validChar :: [Char] 81 | validChar = validStartChar <> ['A'..'Z'] <> ['0'..'9'] <> ['_'] 82 | -------------------------------------------------------------------------------- /src/Inspector/TestVector/TestVector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Inspector.TestVector.TestVector 6 | ( TestVector(..) 7 | , testVectorParser 8 | , testVectorBuilder 9 | , Entry(..) 10 | , entryParser 11 | , entryBuilder 12 | , query 13 | , add 14 | , add' 15 | , inputs 16 | , outputs 17 | ) where 18 | 19 | import Foundation hiding (String, Array) 20 | import Foundation.Collection (KeyedCollection, Element, IndexedCollection(..)) 21 | import qualified Foundation as F (String) 22 | import qualified Foundation.Collection as F 23 | 24 | import Control.Monad (void, forM_) 25 | import GHC.TypeLits 26 | 27 | import Inspector.Parser (Parser) 28 | import qualified Inspector.Parser as Parser 29 | import Inspector.Builder 30 | import Inspector.TestVector.Types (Type) 31 | import Inspector.TestVector.Value (Value, valueParser, getValueType, valueBuilder) 32 | import Inspector.TestVector.Key (Key, keyParser, symbolKey_, keyToString) 33 | 34 | data Entry a = Entry 35 | { entryKey :: !Key 36 | , entryValue :: !Value 37 | , entryType :: !Type 38 | , entryInput :: !(Maybe Bool) 39 | , entryDoc :: !(Maybe F.String) 40 | , entryExtra :: !a 41 | } 42 | deriving (Show, Eq, Ord, Typeable) 43 | 44 | entryParser :: Parser (Entry ()) 45 | entryParser = do 46 | key <- keyParser 47 | Parser.whiteSpaces >> Parser.element '=' >> Parser.whiteSpaces 48 | value <- valueParser 49 | pure $ Entry key value (getValueType value) Nothing Nothing () 50 | 51 | entryBuilder :: Entry (Type, Value) -> Builder () 52 | entryBuilder Entry{..} = do 53 | emit (keyToString entryKey) >> emit " = " 54 | -- align to the given key length 55 | indent $ length (keyToString entryKey) + 3 56 | -- build the value based on the type 57 | valueBuilder (snd entryExtra) (fst entryExtra) 58 | -- remove the alignment 59 | unindent 60 | newline 61 | 62 | newtype TestVector a = TestVector [(Key, Entry a)] 63 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 64 | 65 | type instance Element (TestVector a) = (Key, Entry a) 66 | 67 | instance KeyedCollection (TestVector a) where 68 | type Key (TestVector a) = Key 69 | type Value (TestVector a) = Entry a 70 | lookup k = F.lookup k . toList 71 | 72 | instance IsList (TestVector a) where 73 | type Item (TestVector a) = (Key, Entry a) 74 | toList (TestVector l) = l 75 | fromList = TestVector 76 | 77 | inputs :: TestVector a -> [Entry a] 78 | inputs = filter (fromMaybe undefined . entryInput) . fmap snd . toList 79 | 80 | outputs :: TestVector a -> [Entry a] 81 | outputs = filter (not . fromMaybe undefined . entryInput) . fmap snd . toList 82 | 83 | query :: KnownSymbol key => Proxy key -> TestVector a -> Maybe (Entry a) 84 | query = F.lookup . symbolKey_ 85 | 86 | add' :: Key -> Entry a -> TestVector a -> TestVector a 87 | add' key val (TestVector l) = TestVector $ (key, val) : l 88 | 89 | add :: KnownSymbol key => Proxy key -> Entry a -> TestVector a -> TestVector a 90 | add p = add' (symbolKey_ p) 91 | 92 | testVectorParser :: Parser (TestVector ()) 93 | testVectorParser = fmap fromList $ do 94 | void $ Parser.many Parser.comment 95 | Parser.elements "TestVector" 96 | Parser.newline 97 | Parser.some go 98 | where 99 | go = do 100 | Parser.whiteSpacesAndNewLines 101 | r <- entryParser <* Parser.newline 102 | Parser.whiteSpacesAndNewLines 103 | pure (entryKey r, r) 104 | 105 | testVectorBuilder :: TestVector (Type, Value) -> Builder () 106 | testVectorBuilder tvs = do 107 | emit "TestVector" >> newline 108 | forM_ (toList tvs) (entryBuilder . snd) 109 | newline 110 | -------------------------------------------------------------------------------- /src/Inspector/TestVector/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Inspector.TestVector.Types 5 | ( Type(..) 6 | , Array(..) 7 | , Object(..) 8 | , isByteArray 9 | , innerType 10 | ) where 11 | 12 | import Foundation hiding (String, Array) 13 | import Foundation.Collection (KeyedCollection, Element, IndexedCollection(..)) 14 | import qualified Foundation.Collection as F 15 | 16 | import Inspector.TestVector.Key (Key) 17 | 18 | data Type 19 | = Boolean 20 | | Unsigned8 21 | | Unsigned16 22 | | Unsigned32 23 | | Unsigned64 24 | | Signed8 25 | | Signed16 26 | | Signed32 27 | | Signed64 28 | | Float32 29 | | Float64 30 | | String 31 | | Array !Array 32 | | Object !Object 33 | deriving (Show, Eq, Ord, Typeable) 34 | 35 | isByteArray :: Type -> Bool 36 | isByteArray (Array (SizedArray Unsigned8 _)) = True 37 | isByteArray (Array (UnsizedArray Unsigned8)) = True 38 | isByteArray _ = False 39 | 40 | innerType :: Type -> Type 41 | innerType (Array (SizedArray t _)) = t 42 | innerType (Array (UnsizedArray t)) = t 43 | innerType _ = undefined 44 | 45 | data Array 46 | = SizedArray !Type !Word64 47 | | UnsizedArray !Type 48 | deriving (Show, Eq, Ord, Typeable) 49 | 50 | newtype Object = ObjectDef [(Key, Type)] 51 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 52 | 53 | type instance Element Object = (Key, Type) 54 | 55 | instance KeyedCollection Object where 56 | type Key Object = Key 57 | type Value Object = Type 58 | lookup k = F.lookup k . toList 59 | 60 | instance IsList Object where 61 | type Item Object = (Key, Type) 62 | toList (ObjectDef l) = l 63 | fromList = ObjectDef 64 | -------------------------------------------------------------------------------- /src/Inspector/TestVector/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Inspector.TestVector.Value 5 | ( Value(..) 6 | , valueParser 7 | , valueBuilder 8 | , getValueType 9 | , Array 10 | , mkArray 11 | , arrayParser 12 | , Object(..) 13 | , objectParser 14 | ) where 15 | 16 | import Foundation hiding (String, Array) 17 | import qualified Foundation as F 18 | import Foundation.Collection (KeyedCollection, Element, IndexedCollection(..)) 19 | import qualified Foundation.Collection as F 20 | import Foundation.Check (Arbitrary(..), Gen, oneof, between, frequency, elements) 21 | import Foundation.Collection (nonEmpty_) 22 | import Foundation.String.Read 23 | 24 | import Basement.Bounded 25 | 26 | import Inspector.TestVector.Key (Key, keyParser, keyToString) 27 | import Inspector.TestVector.Types (Type) 28 | import qualified Inspector.TestVector.Types as Type 29 | import Inspector.Parser (Parser) 30 | import qualified Inspector.Parser as Parser 31 | import Inspector.Builder 32 | 33 | import Control.Monad (replicateM, forM_) 34 | 35 | -- | represent a value in the Inspector's intermetidate language 36 | -- 37 | -- The ideal being to have only one representation to build from/to for 38 | -- every output type 39 | data Value 40 | = Boolean Bool 41 | | Integer Integer 42 | | Floating Double 43 | | String F.String 44 | | Array !Array 45 | | Object !Object 46 | deriving (Show, Eq, Ord, Typeable) 47 | instance Arbitrary Value where 48 | arbitrary = genValue defaultDepth 49 | 50 | getValueType :: Value -> Type 51 | getValueType (Boolean _) = Type.Boolean 52 | getValueType (Integer _) = Type.Signed64 53 | getValueType (Floating _) = Type.Float64 54 | getValueType (String _) = Type.String 55 | getValueType (Array (ArrayDef [])) = Type.Array (Type.UnsizedArray Type.Boolean) 56 | getValueType (Array (ArrayDef (x:_))) = Type.Array (Type.UnsizedArray (getValueType x)) 57 | getValueType (Object (ObjectDef lv)) = Type.Object (Type.ObjectDef (fmap (\(k, v) -> (k, getValueType v)) lv)) 58 | 59 | -- | test the given Values are of the same type 60 | valueEq :: Value -> Value -> Bool 61 | valueEq (Boolean _) (Boolean _) = True 62 | valueEq (Integer _) (Integer _) = True 63 | valueEq (Floating _) (Floating _) = True 64 | valueEq (String _) (String _) = True 65 | valueEq (Array l) (Array r) = arrayEq l r 66 | valueEq (Object l) (Object r) = objectEq l r 67 | valueEq _ _ = False 68 | 69 | -- | represent a collection of value 70 | -- 71 | -- the only contraint is that the value must be of the same type. 72 | -- 73 | newtype Array = ArrayDef [Value] 74 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 75 | type instance Element Array = Value 76 | instance IsList Array where 77 | type Item Array = Value 78 | toList (ArrayDef l) = l 79 | fromList = fromMaybe (error "Invalid Array") . mkArray 80 | instance Arbitrary Array where 81 | arbitrary = genArray defaultDepth 82 | 83 | -- | smart constructor, check the value are of the same type before allowing 84 | -- constructing it. 85 | mkArray :: [Value] -> Maybe Array 86 | mkArray [] = Just $ ArrayDef [] 87 | mkArray [a] = Just $ ArrayDef [a] 88 | mkArray (x:xs) = if and $ fmap (valueEq x) xs 89 | then Just $ ArrayDef $ x : xs 90 | else Nothing 91 | 92 | -- | test the given Arrays are of the same type 93 | arrayEq :: Array -> Array -> Bool 94 | arrayEq (ArrayDef l) (ArrayDef r) = and $ fmap (uncurry valueEq) $ zip l r 95 | 96 | newtype Object = ObjectDef [(Key, Value)] 97 | deriving (Show, Eq, Ord, Typeable, Semigroup, Monoid, Collection, Sequential, IndexedCollection, Foldable) 98 | instance Arbitrary Object where 99 | arbitrary = genObject defaultDepth 100 | 101 | type instance Element Object = (Key, Value) 102 | 103 | instance KeyedCollection Object where 104 | type Key Object = Key 105 | type Value Object = Value 106 | lookup k = F.lookup k . toList 107 | 108 | instance IsList Object where 109 | type Item Object = (Key, Value) 110 | toList (ObjectDef l) = l 111 | fromList = ObjectDef 112 | 113 | -- | test the given Objects are of the same type 114 | objectEq :: Object -> Object -> Bool 115 | objectEq (ObjectDef l) (ObjectDef r) = and $ fmap test $ zip l r 116 | where 117 | test ((kl, vl), (kr, vr)) = kl == kr && valueEq vl vr 118 | 119 | -- Helpers -------------------------------------------------------------------- 120 | 121 | zip :: [a] -> [b] -> [(a,b)] 122 | zip = F.zip 123 | {-# INLINE zip #-} 124 | 125 | -- Builder -------------------------------------------------------------------- 126 | 127 | valueBuilder :: Value -> Type -> Builder () 128 | valueBuilder (Boolean b) _ = emit $ if b then "true" else "false" 129 | valueBuilder (Integer i) _ = emit (show i) 130 | valueBuilder (Floating f) _ = emit (show f) -- TODO 131 | valueBuilder (String s) _ = emit (show s) 132 | valueBuilder (Array arr) t 133 | | Type.isByteArray t = do 134 | emit "\"" 135 | forM_ (toList arr) $ \v -> hexadecimalBuilder v (Type.innerType t) 136 | emit "\"" 137 | | otherwise = case toList arr of 138 | [] -> emit "[]" 139 | [x] -> emit "[ " >> indent 2 >> valueBuilder x (Type.innerType t) >> unindent >> emit " ]" 140 | (x:xs) -> do 141 | emit "[ " >> indent 2 >> valueBuilder x (Type.innerType t) >> unindent >> newline 142 | forM_ xs $ \v -> do 143 | emit ", " 144 | indent 2 >> valueBuilder v (Type.innerType t) >> unindent 145 | newline 146 | emit "]" 147 | valueBuilder (Object obj) _ = case toList obj of 148 | [] -> emit "{}" 149 | [(k,v)] -> do 150 | let str = keyToString k <> " = " 151 | emit "{ " >> emit str >> indent (2 + length str) >> valueBuilder v (getValueType v) >> unindent >> emit " }" 152 | (k1,v1):xs -> do 153 | let str = "{ " <> keyToString k1 <> " = " 154 | emit str >> indent (length str) >> valueBuilder v1 (getValueType v1) >> unindent >> newline 155 | forM_ xs $ \(k, v) -> do 156 | let str' = ", " <> keyToString k <> " = " 157 | emit str' >> indent (length str') >> valueBuilder v (getValueType v) >> unindent 158 | newline 159 | emit "}" 160 | 161 | 162 | hexadecimalBuilder :: Value -> Type -> Builder () 163 | hexadecimalBuilder (Integer x) Type.Signed8 = pad 2 x 164 | hexadecimalBuilder (Integer x) Type.Unsigned8 = pad 2 x 165 | hexadecimalBuilder (Integer x) Type.Signed16 = pad 4 x 166 | hexadecimalBuilder (Integer x) Type.Unsigned16 = pad 4 x 167 | hexadecimalBuilder (Integer x) Type.Signed32 = pad 8 x 168 | hexadecimalBuilder (Integer x) Type.Unsigned32 = pad 8 x 169 | hexadecimalBuilder (Integer x) Type.Signed64 = pad 16 x 170 | hexadecimalBuilder (Integer x) Type.Unsigned64 = pad 16 x 171 | hexadecimalBuilder v t = error $ 172 | "tried to write into hexadecimal the value: " <> show v <> "\n" <> 173 | "With the type " <> show t <> ". But this is not a supported type \n" <> 174 | "For this operation." 175 | 176 | pad :: Word -> Integer -> Builder () 177 | pad n = emit . go 0 178 | where 179 | go k v 180 | | v == 0 = replicate (toCount $ fromIntegral $ n - k) '0' 181 | | k > n = "" 182 | | otherwise = 183 | let (q, r) = divMod v 16 184 | in go (k + 1) r <> (showHex q) 185 | 186 | showHex 0 = "0" 187 | showHex 1 = "1" 188 | showHex 2 = "2" 189 | showHex 3 = "3" 190 | showHex 4 = "4" 191 | showHex 5 = "5" 192 | showHex 6 = "6" 193 | showHex 7 = "7" 194 | showHex 8 = "8" 195 | showHex 9 = "9" 196 | showHex 10 = "a" 197 | showHex 11 = "b" 198 | showHex 12 = "c" 199 | showHex 13 = "d" 200 | showHex 14 = "e" 201 | showHex 15 = "f" 202 | showHex _ = error "impossible happened" 203 | 204 | -- Parser --------------------------------------------------------------------- 205 | 206 | -- | parses a Value 207 | valueParser :: Parser Value 208 | valueParser = parserBool 209 | <|> parserDouble 210 | <|> parserInteger 211 | <|> parserString 212 | <|> (Array <$> arrayParser) 213 | <|> (Object <$> objectParser) 214 | 215 | parserBool :: Parser Value 216 | parserBool = fmap Boolean $ (Parser.elements "true" >> pure True) 217 | <|> (Parser.elements "false" >> pure False) 218 | <|> Parser.reportError (Parser.Expected "true or false" "") 219 | 220 | parserInteger :: Parser Value 221 | parserInteger = fmap Integer $ do 222 | r <- Parser.takeWhile_ (`elem` ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']) 223 | case readInteger r of 224 | Nothing -> Parser.reportError (Parser.Expected "Integer" ("got " <> r)) 225 | Just v -> pure v 226 | 227 | parserDouble :: Parser Value 228 | parserDouble = fmap Floating $ do 229 | r <- Parser.takeWhile_ (`elem` ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']) 230 | Parser.element '.' 231 | d <- Parser.takeWhile_ (`elem` ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']) 232 | mexp <- Parser.optional $ do 233 | Parser.element 'e' 234 | ("e" <>) <$> Parser.takeWhile_ (`elem` ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '-']) 235 | case readDouble (r <> "." <> d <> maybe mempty id mexp) of 236 | Nothing -> Parser.reportError (Parser.Expected "Double" ("received invalid: " <> r)) 237 | Just v -> pure v 238 | 239 | parserString :: Parser Value 240 | parserString = fmap String $ Parser.element '"' *> quotedParser <* Parser.element '"' 241 | where 242 | quotedParser = do 243 | s <- Parser.takeWhile_ ('"' /=) 244 | case unsnoc s of 245 | Just (_, '\\') -> Parser.skip 1 >> mappend (snoc s '"') <$> quotedParser 246 | _ -> pure s 247 | 248 | -- | parses an array. Expect element of the array to be of the same type 249 | arrayParser :: Parser Array 250 | arrayParser = do 251 | Parser.element '[' 252 | Parser.whiteSpacesAndNewLines 253 | l <- go <|> pure [] 254 | Parser.whiteSpacesAndNewLines 255 | Parser.element ']' 256 | case mkArray l of 257 | Nothing -> Parser.reportError (Parser.Expected "Same typed values in array" "incompatible types") 258 | Just ar -> pure ar 259 | where 260 | go = do 261 | Parser.whiteSpacesAndNewLines 262 | r <- valueParser 263 | Parser.whiteSpacesAndNewLines 264 | (Parser.element ',' *> ((:) r <$> go)) <|> pure [r] 265 | 266 | -- | parses an object 267 | objectParser :: Parser Object 268 | objectParser = fmap ObjectDef $ do 269 | Parser.element '{' 270 | Parser.whiteSpacesAndNewLines 271 | l <- go <|> pure [] 272 | Parser.whiteSpacesAndNewLines 273 | Parser.element '}' 274 | pure l 275 | where 276 | go = do 277 | Parser.whiteSpacesAndNewLines 278 | n <- keyParser 279 | Parser.whiteSpacesAndNewLines 280 | Parser.element '=' 281 | Parser.whiteSpacesAndNewLines 282 | r <- valueParser 283 | Parser.whiteSpacesAndNewLines 284 | (Parser.element ',' *> ((:) (n, r) <$> go)) <|> pure [(n, r)] 285 | 286 | -- Gen ------------------------------------------------------------------------ 287 | 288 | -- type alias, the depth we are recuring when constructing a given Value 289 | type Depth = Zn64 8 290 | 291 | defaultDepth :: Depth 292 | defaultDepth = zn64 4 293 | 294 | genValue :: Depth -> Gen Value 295 | genValue n 296 | | n == 0 = oneof $ nonEmpty_ 297 | [ Boolean <$> arbitrary 298 | , Integer <$> arbitrary 299 | , Floating <$> arbitrary 300 | , String <$> arbitrary 301 | ] 302 | | otherwise = frequency $ nonEmpty_ 303 | [ (15, Boolean <$> arbitrary) 304 | , (15, Integer <$> arbitrary) 305 | , (15, Floating <$> arbitrary) 306 | , (20, String <$> arbitrary) 307 | , (10, Array <$> genArray (n - 1)) 308 | , ( 5, Object <$> genObject (n - 1)) 309 | ] 310 | 311 | genValueType :: Depth -> Gen (Gen Value) 312 | genValueType n 313 | | n == 0 = elements $ nonEmpty_ 314 | [ Boolean <$> arbitrary 315 | , Integer <$> arbitrary 316 | , Floating <$> arbitrary 317 | , String <$> arbitrary 318 | ] 319 | | otherwise = elements $ nonEmpty_ 320 | [ Boolean <$> arbitrary 321 | , Integer <$> arbitrary 322 | , Floating <$> arbitrary 323 | , String <$> arbitrary 324 | , Array <$> genArray (n - 1) 325 | , Object <$> genObject (n - 1) 326 | ] 327 | 328 | genArray :: Depth -> Gen Array 329 | genArray n = do 330 | len <- fromIntegral <$> between (0, 31) 331 | gen <- genValueType n 332 | ArrayDef <$> replicateM len gen 333 | 334 | genObject :: Depth -> Gen Object 335 | genObject n = do 336 | len <- fromIntegral <$> between (0, 31) 337 | keys <- replicateM len arbitrary 338 | vals <- replicateM len (genValue n) 339 | pure $ ObjectDef $ F.zip keys vals 340 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : abc0bd46f6a4c9fb80a09ae5e27342bfacd2730263d83eea1bb2ef19fae5a3cf ~*~ 2 | { resolver: nightly-2018-06-10, packages: [ '.' ], extra-deps: [ basement-0.0.7, foundation-0.0.20, memory-0.14.15, cryptonite-0.25 ], flags: {} } 3 | 4 | -------------------------------------------------------------------------------- /tests/goldens/hash/SHA1: -------------------------------------------------------------------------------- 1 | # Test Vector 1 2 | TestVector 3 | hash = "da39a3ee5e6b4b0d3255bfef95601890afd80709" 4 | payload = "" 5 | 6 | # Test Vector 2 7 | TestVector 8 | hash = "2fd4e1c67a2d28fced849ee1bb76e7391b93eb12" 9 | payload = "The quick brown fox jumps over the lazy dog" 10 | 11 | # Test Vector 3 12 | TestVector 13 | hash = "de9f2c7fd25e1b3afad3e85a0bd17d9b100db4b3" 14 | payload = "The quick brown fox jumps over the lazy cog" 15 | 16 | -------------------------------------------------------------------------------- /tests/goldens/hash/SHA256: -------------------------------------------------------------------------------- 1 | # Test Vector 1 2 | TestVector 3 | hash = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" 4 | payload = "" 5 | 6 | -------------------------------------------------------------------------------- /tests/goldens/kdf/PBKDF2/SHA1: -------------------------------------------------------------------------------- 1 | # Test Vector 1 2 | TestVector 3 | hash = "a2c2646186828474b754591a547c18f132d88d744c152655a470161a1a0521353263e5f7e0793eec45dc2cf62066f632abcc75756381fd3f0921e9d786c763e6" 4 | salt = "salt" 5 | password = "password" 6 | parameters = { iter = 10000 7 | , len = 64 8 | } 9 | 10 | --------------------------------------------------------------------------------