Add CRM access token to Owner

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+### Added
+
+- Field `crmToken` for `Owner`
+
 ## [1.0.0] - 2022-07-27
 
 ### Added

src/Owner.hs

@@ -40,11 +40,12 @@ data Owner =
     , oexpiration :: UTCTime
     , opayconf :: Bool
     , oviewkey :: T.Text
+    , ocrmToken :: T.Text
     }
   deriving (Eq, Show, Generic, Typeable)
 
 instance ToJSON Owner where
-  toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk) =
+  toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT) =
     case i of
       Just oid ->
         object
@@ -72,6 +73,7 @@ instance ToJSON Owner where
           , "expiration" .= eTs
           , "payconf" .= pc
           , "viewkey" .= vk
+          , "crmToken" .= cT
           ]
       Nothing ->
         object
@@ -99,6 +101,7 @@ instance ToJSON Owner where
           , "expiration" .= eTs
           , "payconf" .= pc
           , "viewkey" .= vk
+          , "crmToken" .= cT
           ]
 
 instance FromJSON Owner where
@@ -128,6 +131,7 @@ instance FromJSON Owner where
       ets <- obj .: "expiration"
       pc <- obj .:? "payconf"
       vk <- obj .:? "viewkey"
+      cT <- obj .:? "crmToken"
       pure $
         Owner
           (if not (null i)
@@ -156,6 +160,7 @@ instance FromJSON Owner where
           ets
           (fromMaybe False pc)
           (fromMaybe "" vk)
+          (fromMaybe "" cT)
 
 instance Val Owner where
   cast' (Doc d) = do
@@ -183,10 +188,36 @@ instance Val Owner where
     ets <- B.lookup "expiration" d
     pc <- B.lookup "payconf" d
     vk <- B.lookup "viewKey" d
+    cT <- B.lookup "crmToken" d
     Just
-      (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk)
+      (Owner
+         i
+         a
+         n
+         c
+         t
+         tV
+         v
+         vV
+         f
+         l
+         e
+         s
+         ct
+         st
+         p
+         ph
+         w
+         co
+         paid
+         zats
+         inv
+         ets
+         pc
+         vk
+         cT)
   cast' _ = Nothing
-  val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk) =
+  val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets pc vk cT) =
     case i of
       Just oid ->
         Doc
@@ -214,6 +245,7 @@ instance Val Owner where
           , "expiration" =: ets
           , "payconf" =: pc
           , "viewKey" =: vk
+          , "crmToken" =: cT
           ]
       Nothing ->
         Doc
@@ -240,6 +272,7 @@ instance Val Owner where
           , "expiration" =: ets
           , "payconf" =: pc
           , "viewKey" =: vk
+          , "crmToken" =: cT
           ]
 
 -- Database actions

test/Spec.hs

@@ -74,7 +74,7 @@ main = do
               "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
       describe "PIN generator" $ do
         it "should give a 7 digit" $ do
-          length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7
+          length (T.unpack (unsafePerformIO (generatePin 1010))) `shouldBe` 7
     describe "API endpoints" $ do
       beforeAll_ (startAPI loadedConfig) $ do
         describe "Price endpoint" $ do
@@ -518,6 +518,7 @@ startAPI config = do
           (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
           False
           ""
+          ""
   _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
   let o = val myOwner
   case o of
@@ -604,8 +605,8 @@ instance Arbitrary Owner where
     inv <- arbitrary
     exp <- arbitrary
     payconf <- arbitrary
-    --exp <- arbitrary
+    vk <- arbitrary
-    Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf <$>
+    Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf vk <$>
       arbitrary
 
 instance Arbitrary Item where

zgo-backend.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           zgo-backend
-version:        0.1.0.2
+version:        1.0.0
 synopsis:       Haskell Back-end for the ZGo point-of-sale application
 description:    Please see the README on GitLab at <https://gitlab.com/pitmutt/zgo-backend#readme>
 category:       Web