feat: New show command (#638)

BREAKING CHANGE: This changes the structure of the message that is
signed before sending it to a machine. Machines set up before this
commit will not accept the new signatures.

`show-unbound` does not add formatting to the requests payload, to
make signing request consistently to work also in other languages.

docs/source/reference.rst

@@ -59,6 +59,11 @@ the the second argument (a list).
 
 Returns a string representing the argument value.
 
+``show-unformatted``
+~~~~~~~~~~~~~~~~~~~~
+
+Returns a string representing the argument value. (No extra formatting)
+
 ``throw``
 ~~~~~~~~~
 

rad/prelude/machine.rad

@@ -165,7 +165,7 @@
     (def ks (get-keys!))
     (def sig
       (gen-signature! (lookup :private-key ks)
-                      (show e_)))
+                      (show-unformatted e_)))
     (<> e_
         {:author    (lookup :public-key ks)
          :signature sig})))

rad/prelude/validation.rad

@@ -243,7 +243,7 @@
        (verify-signature
         (lookup :author d)
         (lookup :signature d)
-        (show (delete-many [:author :signature] d)))))]))
+        (show-unformatted (delete-many [:author :signature] d)))))]))
 
 (test "signed"
   [:setup
@@ -253,12 +253,10 @@
        (def payload
          {:nonce (uuid!)
           :some "data"})
-       (def payload_ (insert :some "datadata" payload))
-       (def sig  (gen-signature! sk (show payload)))
+       (def sig  (gen-signature! sk (show-unformatted payload)))
        (def seal {:author    (lookup :public-key keys)
                   :signature sig})
        (def full (<> payload seal))
-       (def full_ (<> payload_ seal))
        (def ok
          (catch 'validation-failure (do (signed full) :ok) (fn [_] :not-ok)))
        )

reference-doc.yaml

@@ -24,6 +24,7 @@ primFns:
 - eq?
 - apply
 - show
+- show-unformatted
 - throw
 - exit!
 - read-annotated

src/Radicle.hs

@@ -71,6 +71,7 @@ module Radicle
     -- * Pretty-printing
     , renderPretty
     , renderPrettyDef
+    , renderPrettyUnbounded
     , renderCompactPretty
     -- ** Re-exports
     , PageWidth(..)

src/Radicle/Internal/Pretty.hs

@@ -67,7 +67,7 @@ instance forall t. (Copointed t, Ann.Annotation t) => PrettyV (Ann.Annotated t V
         Macro _ -> angles "macro"
         Dict mp -> braces . align $
             sep [ prettyV k <+> prettyV val
-                | (k, val) <- Map.toList mp ]
+                | (k, val) <- Map.toAscList mp ]
         Lambda ids vals _ -> prettyLambda ids vals
         LambdaRec _ ids vals _ -> prettyLambda ids vals
         VEnv _ -> angles "env"
@@ -165,6 +165,15 @@ renderCompactPretty = renderStrict . layoutCompact . prettyV
 renderPretty :: PrettyV v => PageWidth -> v -> Text
 renderPretty pg = renderStrict . layoutSmart (LayoutOptions pg) . prettyV
 
+-- | 'renderPretty', but with unbounded width.
+--
+-- Example:
+--
+-- >>> renderPrettyUnbounded (asValue (List [String "hi", String "there"]))
+-- "(\"hi\" \"there\")"
+renderPrettyUnbounded :: PrettyV v => v -> Text
+renderPrettyUnbounded = renderPretty Unbounded
+
 -- | 'renderPretty', but with default layout options (80 chars, 1.0 ribbon)
 --
 -- Examples:

src/Radicle/Internal/PrimFns.hs

@@ -568,6 +568,9 @@ purePrimFns = fromList $ allDocs $
     , ( "show"
       , "Returns a string representing the argument value."
       , oneArg "show" (pure . String . renderPrettyDef))
+    , ( "show-unformatted"
+      , "Returns a string representing the argument value. (No extra formatting)"
+      , oneArg "show-unformatted" (pure . String . renderPrettyUnbounded))
     , ( "seq"
       , "Given a structure `s`, returns a sequence. Lists and vectors are returned\
         \ without modification while for dicts a vector of key-value-pairs is returned:\

test/spec/Radicle/Internal/Arbitrary.hs

@@ -1,11 +1,14 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-module Radicle.Internal.Arbitrary where
+module Radicle.Internal.Arbitrary
+    ( NoDoubleSpacesValue(..)
+    ) where
 
 import           Protolude
 
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import           Data.Scientific (Scientific)
+import qualified Data.Text as T
 import           Test.QuickCheck
 import           Test.QuickCheck.Instances ()
 
@@ -19,34 +22,14 @@ instance Arbitrary r => Arbitrary (Env r) where
     arbitrary = Env <$> arbitrary
 
 instance Arbitrary Value where
-    arbitrary = sized go
-      where
-        -- There's no literal syntax for dicts, only the 'dict' primop. If we
-        -- generated them directly, we would generate something that can only
-        -- be got at after an eval, and which doesn't really correspond to
-        -- anything a user can write. So we don't generate dicts directly,
-        -- instead requiring they go via the primop.
-        freqs = [ (3, Atom <$> (arbitrary `suchThat` (\x -> not (isPrimop x || isNum x))))
-                , (3, String <$> arbitrary)
-                , (3, Boolean <$> arbitrary)
-                , (3, Number <$> arbitrary)
-                , (1, List <$> sizedList)
-                , (6, PrimFn <$> elements (Map.keys $ getPrimFns prims))
-                , (1, Lambda <$> lambdaArgs
-                             <*> scale (`div` 3) arbitrary
-                             <*> scale (`div` 3) arbitrary)
-                ]
-        go n | n == 0 = frequency $ first pred <$> freqs
-             | otherwise = frequency freqs
-        sizedList :: Arbitrary a => Gen [a]
-        sizedList = sized $ \n -> do
-            k <- choose (0, n)
-            scale (`div` (k + 1)) $ vectorOf k arbitrary
-        prims :: PrimFns Identity
-        prims = purePrimFns
-        isPrimop x = x `elem` Map.keys (getPrimFns prims)
-        isNum x = isJust (readMaybe (toS $ fromIdent x) :: Maybe Scientific)
-        lambdaArgs = oneof [ PosArgs <$> sizedList, VarArgs <$> arbitrary ]
+    arbitrary = sized (valueGenerator arbitrary)
+
+newtype NoDoubleSpacesValue = NoDoubleSpacesValue Value
+  deriving Show
+
+instance Arbitrary NoDoubleSpacesValue where
+    arbitrary = NoDoubleSpacesValue <$> sized (valueGenerator textNoDoubleSpaces)
+      where textNoDoubleSpaces = arbitrary `suchThat` (not . T.isInfixOf "  ")
 
 instance Arbitrary UntaggedValue where
     arbitrary = untag <$> (arbitrary :: Gen Value)
@@ -70,3 +53,33 @@ instance Arbitrary a => Arbitrary (Bindings a) where
 
 instance Arbitrary a => Arbitrary (Doc.Docd a) where
     arbitrary = Doc.Docd Nothing <$> arbitrary
+
+valueGenerator :: Gen Text -> Int -> Gen Value
+valueGenerator textGen n | n == 0 = frequency $ first pred <$> freqs
+                         | otherwise = frequency freqs
+  where
+    -- There's no literal syntax for dicts, only the 'dict' primop. If we
+    -- generated them directly, we would generate something that can only
+    -- be got at after an eval, and which doesn't really correspond to
+    -- anything a user can write. So we don't generate dicts directly,
+    -- instead requiring they go via the primop.
+    freqs = [ (3, Atom <$> (arbitrary `suchThat` (\x -> not (isPrimop x || isNum x))))
+            , (3, String <$> textGen)
+            , (3, Boolean <$> arbitrary)
+            , (3, Number <$> arbitrary)
+            , (1, List <$> sizedList)
+            , (6, PrimFn <$> elements (Map.keys $ getPrimFns prims))
+            , (1, Lambda <$> lambdaArgs
+                         <*> scale (`div` 3) arbitrary
+                         <*> scale (`div` 3) arbitrary)
+            ]
+
+    sizedList :: Arbitrary a => Gen [a]
+    sizedList = sized $ \s -> do
+        k <- choose (0, s)
+        scale (`div` (k + 1)) $ vectorOf k arbitrary
+    prims :: PrimFns Identity
+    prims = purePrimFns
+    isPrimop x = x `elem` Map.keys (getPrimFns prims)
+    isNum x = isJust (readMaybe (toS $ fromIdent x) :: Maybe Scientific)
+    lambdaArgs = oneof [ PosArgs <$> sizedList, VarArgs <$> arbitrary ]

test/spec/Radicle/Tests.hs

@@ -21,7 +21,7 @@ import qualified Text.Megaparsec.Pos as Par
 
 import           Radicle
 import qualified Radicle.Internal.Annotation as Ann
-import           Radicle.Internal.Arbitrary ()
+import           Radicle.Internal.Arbitrary
 import           Radicle.Internal.Core (asValue, noStack)
 import           Radicle.Internal.Foo (Bar(..), Baz(..), Foo)
 import           Radicle.Internal.TestCapabilities
@@ -474,6 +474,16 @@ test_eval =
         runPureCode "(show (dict 'a 1))" @?= Right (String "{a 1}")
         runPureCode "(show (fn [x] x))" @?= Right (String "(fn [x] x)")
 
+    , testCase "'show-unformatted' works" $ do
+        runPureCode "(show-unformatted {:b 2 :a 1})" @?= Right (String "{:a 1 :b 2}")
+        runPureCode "(show-unformatted {:bar \"bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar\" :foo \"foo foo foo foo foo\"})"
+          @?= Right (String "{:bar \"bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar\" :foo \"foo foo foo foo foo\"}")
+
+    , testProperty "'show-unformatted' does not add any whitespace characters" $ \(NoDoubleSpacesValue val :: NoDoubleSpacesValue) -> do
+        let res = runPureCode $ toS [i|(show-unformatted #{renderPrettyUnbounded val})|]
+            info = "Expected to not include any double whitespace characters, line breaks or tabs:\n" <> toS (prettyEither res)
+        counterexample info $ isLeft res || noUnallowedWhitespace (prettyEither res)
+
     , testCase "'read-anotated' works" $
         runPureCode "(read-annotated \"foo\" \"(:hello 42)\")" @?= Right (List [Keyword [ident|hello|], int 42])
 
@@ -574,6 +584,10 @@ test_eval =
   where
     failsWith src err    = noStack (runPureCode src) @?= Left err
     succeedsWith src val = runPureCode src @?= Right val
+    noTabs t = not $ T.any (== '\t') t
+    noLineBreaks t = not $ T.any (== '\n') t
+    noDoubleSpaces t = not $ T.isInfixOf "  " t
+    noUnallowedWhitespace t = noDoubleSpaces t && noLineBreaks t && noTabs t
 
 stackTraceLines :: [Ann.SrcPos] -> [Int]
 stackTraceLines = concatMap go