From 98f732dbd27c95829217bac4bebbfcb20319d77a Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Thu, 31 Dec 2020 08:51:37 +0200
Subject: [PATCH] Test the encoding and decoding

---
 buuka.cabal             |  1 +
 src/Data/Buuka.hs       |  2 ++
 test/MyLibTest.hs       |  2 ++
 test/Test/Data/Buuka.hs | 49 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 54 insertions(+)
 create mode 100644 test/Test/Data/Buuka.hs

diff --git a/buuka.cabal b/buuka.cabal
index bdff1c1..e3261b6 100644
--- a/buuka.cabal
+++ b/buuka.cabal
@@ -67,6 +67,7 @@ executable buuka
 test-suite buuka-test
   import:              common-stanza
   other-modules:       Test.Database.Migrations
+                       Test.Data.Buuka
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             MyLibTest.hs
diff --git a/src/Data/Buuka.hs b/src/Data/Buuka.hs
index dc69d64..38af5c8 100644
--- a/src/Data/Buuka.hs
+++ b/src/Data/Buuka.hs
@@ -5,6 +5,7 @@ module Data.Buuka
   , BuukaU(..)
   , BuukaEntry(..)
   , URL(..)
+  , Buuka
 
   , insert
   )
@@ -38,6 +39,7 @@ instance SafeJSON BuukaEntry where
   type Version BuukaEntry = 0
 
 newtype Buuka = Buuka ( Map URL BuukaEntry )
+  deriving stock (Show, Eq)
   deriving newtype (Semigroup, Monoid, FromJSON, ToJSON)
 
 insert :: BuukaEntry -> Buuka -> Buuka
diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs
index 7a30e62..306f4d7 100644
--- a/test/MyLibTest.hs
+++ b/test/MyLibTest.hs
@@ -2,11 +2,13 @@ module Main (main) where
 
 import Test.Tasty
 
+import qualified Test.Data.Buuka as Data.Buuka
 import qualified Test.Database.Migrations as Database.Migrations
 
 tests :: TestTree
 tests = testGroup "buuka"
   [ Database.Migrations.tests
+  , Data.Buuka.tests
   ]
 
 main :: IO ()
diff --git a/test/Test/Data/Buuka.hs b/test/Test/Data/Buuka.hs
new file mode 100644
index 0000000..5e65b10
--- /dev/null
+++ b/test/Test/Data/Buuka.hs
@@ -0,0 +1,49 @@
+module Test.Data.Buuka where
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import qualified Data.Aeson as A
+
+import Data.List
+       (intercalate)
+import qualified Data.Foldable as F
+
+import Data.Buuka
+
+genUrl :: Gen URL
+genUrl = URL . concat <$> sequence go
+  where
+    go = [ Gen.element protocols, Gen.element domains, Gen.element tlds, pure "/", genPath ]
+    protocols = ["http://", "https://"]
+    domains = ["example", "foo", "bar"]
+    tlds = ["com", "fi", "org", "net", "info"]
+    genPath = intercalate "/" <$> Gen.list (Range.linear 0 10) (Gen.element paths)
+    paths = ["foo", "bar", "asd", "xyzzy"]
+
+genBuukaEntry :: Gen BuukaEntry
+genBuukaEntry = BuukaEntry <$> genUrl <*> genTitle
+  where
+    genTitle = Gen.maybe (Gen.string (Range.linear 0 10) Gen.unicode)
+
+genBuuka :: Gen Buuka
+genBuuka = F.foldl' (flip insert) mempty <$> Gen.list (Range.linear 0 10) genBuukaEntry
+
+prop_buukaentry_encode_decode :: Property
+prop_buukaentry_encode_decode = property $ do
+  x <- forAll genBuukaEntry
+  tripping x A.encode A.eitherDecode
+
+prop_buuka_encode_decode :: Property
+prop_buuka_encode_decode = property $ do
+  x <- forAll genBuuka
+  tripping x A.encode A.eitherDecode
+
+tests :: TestTree
+tests = testGroup "Data.Buuka"
+  [ testProperty "Entries can be encoded and decoded" prop_buukaentry_encode_decode
+  , testProperty "Entire set can be encoded and decoded" prop_buuka_encode_decode
+  ]