ensuring quality of uri generator interim

marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ApiSpec.hs

@@ -9,21 +9,21 @@ module Language.Marlowe.Runtime.Transaction.ApiSpec
 import Language.Marlowe.Runtime.Transaction.Api (CIP25Metadata(..), CIP25MetadataDetails(..))
 
 import Control.Arrow ((&&&), (***))
-import qualified Control.Monad
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Key as Aeson.Key
 import qualified Data.Aeson.KeyMap as Aeson.KeyMap
 import Data.Coerce (coerce)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text.Encoding as Text.Encoding
 import qualified Data.Text.Encoding.Base16 as Base16
 import Language.Marlowe.Runtime.ChainSync.Api (PolicyId(PolicyId), TokenName(TokenName))
 import qualified Network.URI as Network (URI(..), URIAuth(..))
 import qualified Network.URI hiding (URI(..), URIAuth(..))
-import Test.Hspec (Spec, it, shouldBe)
+import Test.Hspec (Spec, it, shouldBe, shouldSatisfy)
 import qualified Test.Hspec as Hspec
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck (Gen)
@@ -80,29 +80,7 @@ validityProp =
     pure (undefined, undefined)
 
   uriJSONRelationGen :: Gen (Network.URI, Aeson.Value)
-  uriJSONRelationGen = do
-    uriScheme :: String <- do
-      c <- Gen.oneof [charLetterGen, charCapitalLetterGen]
-      fmap (c:) $ Gen.listOf $ Gen.oneof [charLetterGen, charCapitalLetterGen, charNumberGen]
-
-    let uri :: Network.URI
-        uri = Network.URI.rectify $ Network.URI uriScheme undefined undefined undefined undefined
-        json :: String
-        json = show uri
-
-    Control.Monad.unless (Network.URI.isURI json) $
-      error $ "QuickCheck Gen sanity check: " <> json <> " is not a valid URI!"
-
-    pure (uri, Aeson.String $ fromString json)
-
-  charLetterGen :: Gen Char
-  charLetterGen = Gen.elements ['a' .. 'z']
-
-  charCapitalLetterGen :: Gen Char
-  charCapitalLetterGen = Gen.elements ['A' .. 'Z']
-
-  charNumberGen :: Gen Char
-  charNumberGen = Gen.elements ['0' .. '0']
+  uriJSONRelationGen = undefined
 
   policyIdJSONKeyRelationGen :: Gen (PolicyId, Aeson.Key)
   policyIdJSONKeyRelationGen = do
@@ -116,15 +94,49 @@ validityProp =
     (mkTokenName &&& Aeson.Key.fromText)
       <$> base16EncodedTextGen n
 
+uriGenProp :: Gen.Property
+uriGenProp = Gen.checkCoverage $
+  Gen.forAll uriGen \uri@Network.URI {..} ->
+    Gen.cover 25.0 (Maybe.isJust uriAuthority) "has uriAuthority" $
+    Gen.cover 25.0 (Maybe.isNothing uriAuthority) "hasn't uriAuthority" do
+    uri `shouldSatisfy` Network.URI.isURI . show
+
+uriGen :: Gen Network.URI
+uriGen = do
+  uriScheme <- do
+    c <- Gen.oneof [charLetterGen]
+    fmap (c:) $ Gen.listOf $ Gen.oneof [charLetterGen, charNumberGen]
+
+  uriAuthority <-
+    Gen.oneof
+      [ pure Nothing
+      , do
+          uriUserInfo <- Gen.listOf specialCharGen
+          uriRegName <- Gen.listOf specialCharGen
+          uriPort <- Gen.listOf1 charNumberGen
+          pure $ Just $ Network.URIAuth {..}
+      ]
+
+  uriPath <- ('/':) <$> Gen.listOf specialCharGen
+  uriQuery <- Gen.listOf specialCharGen
+  uriFragment <- Gen.listOf specialCharGen
+
+  pure $ Network.URI.rectify $ Network.URI {..}
+
+  where
+  specialCharGen :: Gen Char
+  specialCharGen = Gen.oneof [charLetterGen, charNumberGen, Gen.elements ['.', '/', '-', '_', '?', '=', ';']]
+
+  charLetterGen :: Gen Char
+  charLetterGen = Gen.elements $ ['a' .. 'z'] <> ['A' .. 'Z']
+
+  charNumberGen :: Gen Char
+  charNumberGen = Gen.elements ['0' .. '9']
+
 spec :: Spec
 spec = do
   Hspec.fdescribe "CIP-25 Metadata" do
-    let myval =
-          Network.URI "A1" (Just $ Network.URI.rectifyAuth $ Network.URIAuth "xyz" "uvw" "4040") "/def" "ghi" "jkl"
-    Hspec.focus $ it "Network.URI 1" do
-      (Network.URI.isURI $ show $ Network.URI.rectify myval) `shouldBe` True
-    it "Network.URI 2" do
-      (show $ Network.URI.rectify myval) `shouldBe` ""
+    Hspec.focus $ prop "uri generator is correct and of good quality" uriGenProp
     prop "accepts valid values" $ Gen.checkCoverage validityProp
     -- Hspec.describe "version 1" do
     --   prop "deserialization is not supported" do