Correct parsing of memos

CHANGELOG.md

@@ -4,6 +4,57 @@ All notable changes to this project will be documented in this file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
 and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
+## [Unreleased]
+
+### Added
+
+- New type to handle UI translation objects
+- New endpoints for API to get/set translation
+- Tests for translation endpoints
+- Formal parser of ZGo-related tokens in memos
+
+### Changed
+
+- Remove old code for PIN generation
+- Xero reference field to include the amount of ZEC received
+- Separate periodic tasks from API server
+- Zcash transaction monitoring changed to use memo parser
+
+## [1.2.5] - 2023-02-01
+
+### Fixed
+
+- Replaced the PIN generation with the cryptographically-secure `crypto-rng`.
+
+## [1.2.4] - 2023-01-30
+
+### Changed
+
+- Enhance payments to account for early payments on active sessions.
+
+## [1.2.3] - 2023-01-27
+
+### Changed
+
+- Implement `BLAKE3` for PIN hashing.
+
+## [1.2.2] - 2023-01-25
+
+### Fixed
+
+- Corrected selection criteria for expiring owners query
+
+## [1.2.1] - 2023-01-24
+
+### Added
+
+- New configuration fields for SMTP
+
+### Fixed
+
+- Owner expiration query
+- Xero token expiration query
+
 ## [1.2.0] - 2023-01-09
 
 ### Added

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2022 Vergara Technologies LLC
+Copyright (c) 2023 Vergara Technologies LLC
 
 =======================================================
 Bootstrap Open Source Licence ("BOSL") v. 1.0

README.md

@@ -1,5 +1,7 @@
 # ZGo Back End
 
+[![Please don't upload to GitHub](https://nogithub.codeberg.page/badge.svg)](https://nogithub.codeberg.page)
+
 The API server behind the [ZGo.cash](https://zgo.cash) app.
 
 ## Dependencies

app/Server.hs

@@ -3,7 +3,8 @@
 module Server where
 
 import Config
-import Control.Concurrent (forkIO)
+
+--import Control.Concurrent (forkIO)
 import Database.MongoDB
 import Network.Wai.Handler.Warp (defaultSettings, setPort)
 import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
@@ -30,12 +31,12 @@ main = do
   if j
     then putStrLn "Connected to MongoDB!"
     else fail "MongoDB connection failed!"
-  _ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig)))
-  _ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))
-  _ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))
-  _ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))
-  _ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))
-  _ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))
+  {-_ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig)))-}
+  {-_ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))-}
+  {-_ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))-}
+  {-_ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))-}
+  {-_ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))-}
+  {-_ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))-}
   let appRoutes = routes pipe loadedConfig
   case myTlsSettings of
     Nothing -> scotty (c_port loadedConfig) appRoutes

app/Tasks.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tasks where
+
+import Config
+import Database.MongoDB
+import ZGoBackend
+
+main :: IO ()
+main = do
+  putStrLn "ZGo Recurring Tasks"
+  putStrLn "Reading config..."
+  loadedConfig <- loadZGoConfig "zgo.cfg"
+  pipe <- connect $ host (c_dbHost loadedConfig)
+  j <-
+    access
+      pipe
+      master
+      (c_dbName loadedConfig)
+      (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig))
+  if j
+    then do
+      putStrLn "Connected to MongoDB!"
+      checkZcashPrices pipe (c_dbName loadedConfig)
+      scanZcash' loadedConfig pipe
+      scanPayments loadedConfig pipe
+      checkPayments pipe (c_dbName loadedConfig)
+      expireOwners pipe (c_dbName loadedConfig)
+      updateLogins pipe loadedConfig
+      close pipe
+    else fail "MongoDB connection failed!"

package.yaml

@@ -1,10 +1,10 @@
 name:                zgo-backend
-version:             1.2.0
+version:             1.3.0
 git:                 "https://git.vergara.tech/Vergara_Tech/zgo-backend"
 license:             BOSL
 author:              "Rene Vergara"
 maintainer:          "rene@vergara.network"
-copyright:           "Copyright (c) 2022 Vergara Technologies LLC"
+copyright:           "Copyright (c) 2023 Vergara Technologies LLC"
 
 extra-source-files:
 - README.md
@@ -58,6 +58,10 @@ library:
   - blake3
   - memory
   - ghc-prim
+  - network
+  - crypto-rng
+  - megaparsec
+  - uuid
 
 executables:
   zgo-backend-exe:
@@ -85,6 +89,7 @@ executables:
             - configurator
             - warp-tls
             - warp
+            - megaparsec
   zgo-token-refresh:
     main:                TokenRefresh.hs
     source-dirs:         app
@@ -111,7 +116,25 @@ executables:
             - configurator
             - warp-tls
             - warp
-
+            - megaparsec
+  zgo-tasks:
+    main:                Tasks.hs
+    source-dirs:         app
+    ghc-options:
+            - -main-is Tasks
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
+    dependencies:
+            - base
+            - mongoDB
+            - zgo-backend
+            - scotty
+            - warp-tls
+            - warp
+            - time
+            - megaparsec
 
 tests:
   zgo-backend-test:

src/Config.hs

@@ -6,6 +6,7 @@ import qualified Data.ByteString as BS
 import Data.Configurator
 import Data.SecureMem
 import qualified Data.Text as T
+import Network.Socket (PortNumber)
 
 data Config =
   Config
@@ -21,6 +22,10 @@ data Config =
     , c_useTls :: Bool
     , c_certificate :: String
     , c_key :: String
+    , c_smtpHost :: String
+    , c_smtpPort :: Integer
+    , c_smtpUser :: String
+    , c_smtpPwd :: String
     }
   deriving (Eq, Show)
 
@@ -39,6 +44,10 @@ loadZGoConfig path = do
   useTls <- require config "tls"
   cert <- require config "certificate"
   key <- require config "key"
+  mailHost <- require config "smtpHost"
+  mailPort <- require config "smtpPort"
+  mailUser <- require config "smtpUser"
+  mailPwd <- require config "smtpPwd"
   return $
     Config
       dbHost
@@ -53,3 +62,7 @@ loadZGoConfig path = do
       useTls
       cert
       key
+      mailHost
+      mailPort
+      mailUser
+      mailPwd

src/LangComponent.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module LangComponent where
+
+import Data.Aeson
+import Data.Aeson.KeyMap
+import qualified Data.Bson as B
+import Data.ByteString.Builder.Extra (AllocationStrategy)
+import Data.Maybe
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import Database.MongoDB
+import Xero (Xero(x_clientId))
+
+-- | Type to represent a UI components text variables in different languages
+data LangComponent =
+  LangComponent
+    { lc_id :: Maybe ObjectId
+    , lc_lang :: T.Text
+    , lc_component :: T.Text
+    , lc_data :: Data.Aeson.Object
+    }
+  deriving (Show, Eq)
+
+instance ToJSON LangComponent where
+  toJSON (LangComponent i l c d) =
+    case i of
+      Just oid ->
+        object
+          ["_id" .= show oid, "language" .= l, "component" .= c, "data" .= d]
+      Nothing ->
+        object
+          [ "_id" .= ("" :: String)
+          , "language" .= l
+          , "component" .= c
+          , "data" .= d
+          ]
+
+instance FromJSON LangComponent where
+  parseJSON =
+    withObject "LangComponent" $ \obj -> do
+      l <- obj .: "language"
+      c <- obj .: "component"
+      d <- obj .: "data"
+      pure $ LangComponent Nothing l c d
+
+instance Val LangComponent where
+  val (LangComponent i l c d) =
+    if isJust i
+      then Doc
+             [ "_id" =: i
+             , "language" =: l
+             , "component" =: c
+             , "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d
+             ]
+      else Doc
+             [ "language" =: l
+             , "component" =: c
+             , "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d
+             ]
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    l <- B.lookup "language" d
+    c <- B.lookup "component" d
+    dt <- B.lookup "data" d
+    pure $
+      LangComponent
+        i
+        l
+        c
+        (fromMaybe
+           Data.Aeson.KeyMap.empty
+           ((decode . TLE.encodeUtf8 . TL.fromStrict) dt))
+
+-- Database Actions
+findLangComponent :: T.Text -> T.Text -> Action IO (Maybe Document)
+findLangComponent lang component =
+  findOne (select ["language" =: lang, "component" =: component] "langcomps")
+
+loadLangComponent :: LangComponent -> Action IO ()
+loadLangComponent lc = do
+  let langComp = val lc
+  case langComp of
+    Doc x ->
+      upsert
+        (select
+           ["language" =: lc_lang lc, "component" =: lc_component lc]
+           "langcomps")
+        x
+    _ -> error "Couldn't parse language JSON"

src/Owner.hs

@@ -292,3 +292,12 @@ findOwner zaddy = findOne (select ["address" =: zaddy] "owners")
 findOwnerById :: T.Text -> Action IO (Maybe Document)
 findOwnerById i =
   findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners")
+
+-- | Function to find Owners about to expire
+findExpiringOwners :: UTCTime -> Action IO [Document]
+findExpiringOwners now =
+  rest =<<
+  find
+    (select
+       ["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
+       "owners")

src/User.hs

@@ -6,6 +6,8 @@ module User where
 
 import Control.Monad
 import Control.Monad.IO.Class
+import Crypto.RNG
+import Crypto.RNG.Utils
 import Data.Aeson
 import qualified Data.Bson as B
 import Data.Maybe
@@ -99,11 +101,11 @@ validateUser session =
     (select ["session" =: session] "users")
     ["$set" =: ["validated" =: True]]
 
-generatePin :: Int -> IO T.Text
-generatePin s = do
-  let g = mkStdGen s
-  pure $
-    T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)
+generatePin :: IO String
+generatePin = do
+  rngState <- newCryptoRNGState
+  runCryptoRNGT rngState $
+    randomString 7 ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
 
 -- | Helper function to pad a string to a given length
 padLeft :: String -> Char -> Int -> String

src/Xero.hs

@@ -283,8 +283,7 @@ findToken a = findOne (select ["address" =: a] "xerotokens")
 findExpiringTokens :: UTCTime -> Action IO [Document]
 findExpiringTokens now =
   rest =<<
-  find
-    (select ["refExpires" =: ["$lte" =: addUTCTime 1728000 now]] "xerotokens")
+  find (select ["refExpires" =: ["$lte" =: addUTCTime 172800 now]] "xerotokens")
 
 -- | Function to request accesstoken
 requestXeroToken :: Pipe -> T.Text -> Xero -> T.Text -> T.Text -> IO Bool
@@ -411,8 +410,9 @@ getXeroInvoice pipe dbName inv address = do
                 Right iData -> return $ Just (head $ xir_invs iData)
             _ -> return Nothing
 
-payXeroInvoice :: Pipe -> T.Text -> T.Text -> T.Text -> Double -> IO ()
-payXeroInvoice pipe dbName inv address amt = do
+payXeroInvoice ::
+     Pipe -> T.Text -> T.Text -> T.Text -> Double -> Double -> IO ()
+payXeroInvoice pipe dbName inv address amt zec = do
   token <- access pipe master dbName $ findToken address
   let aToken = t_access <$> (token >>= cast' . Doc)
   let aCode = t_code <$> (token >>= cast' . Doc)
@@ -427,7 +427,8 @@ payXeroInvoice pipe dbName inv address amt = do
                  [ "Invoice" .= object ["InvoiceNumber" .= inv]
                  , "Account" .= object ["Code" .= fromMaybe "" aCode]
                  , "Date" .= utctDay today
-                 , "Reference" .= ("Paid in Zcash through ZGo" :: String)
+                 , "Reference" .=
+                   ("Paid in Zcash through ZGo: " ++ show zec ++ " ZEC" :: String)
                  , "Amount" .= amt
                  ]) $
             addRequestHeader "Accept" "application/json" $

src/ZGoBackend.hs

@@ -6,6 +6,7 @@
 
 module ZGoBackend where
 
+import qualified BLAKE3 as BLK
 import Config
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (try)
@@ -14,6 +15,7 @@ import Control.Monad.IO.Class
 import Data.Aeson
 import Data.Array
 import qualified Data.Bson as B
+import qualified Data.ByteArray as BA
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as C
@@ -31,6 +33,7 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Data.Time.Format
 import Data.Typeable
+import qualified Data.UUID as U
 import qualified Data.Vector as V
 import Data.Vector.Internal.Check (doChecks)
 import Data.Word
@@ -38,6 +41,7 @@ import Database.MongoDB
 import Debug.Trace
 import GHC.Generics
 import Item
+import LangComponent
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
 import Network.Wai (Request, pathInfo)
@@ -52,6 +56,7 @@ import System.Random
 import Test.QuickCheck
 import Test.QuickCheck.Instances
 import Test.QuickCheck.Property (Result(ok))
+import Text.Megaparsec (runParser)
 import Text.Regex
 import Text.Regex.Base
 import User
@@ -352,6 +357,27 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
               ZGoTx Nothing nAddy sess conf bt a t m
             else ZGoTx Nothing "" "" conf bt a t m
 
+zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO ()
+zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do
+  when (conf < 100) $ do
+    let zM = runParser pZGoMemo (T.unpack t) m
+    case zM of
+      Right zM' -> do
+        let tx =
+              ZGoTx
+                Nothing
+                (fromMaybe "" $ m_address zM')
+                (maybe "" U.toText $ m_session zM')
+                conf
+                bt
+                a
+                t
+                m
+        if m_payment zM'
+          then upsertPayment pipe (c_dbName config) tx
+          else access pipe master (c_dbName config) $ upsertZGoTx "txs" tx
+      Left e -> error "Failed to parse ZGo memo"
+
 -- |Type to model a price in the ZGo database
 data ZGoPrice =
   ZGoPrice
@@ -424,14 +450,20 @@ addUser _ _ _ _ _ Nothing = return () --`debug` "addUser got Nothing"
 addUser nodeUser nodePwd p db node (Just tx) = do
   isNew <- liftIO $ isUserNew p db tx
   when isNew $ do
-    let newPin = unsafePerformIO (generatePin (fromIntegral $ blocktime tx))
-    _ <- sendPin nodeUser nodePwd node (address tx) newPin
+    newPin <- liftIO generatePin
+    _ <- sendPin nodeUser nodePwd node (address tx) (T.pack newPin)
+    let pinHash =
+          BLK.hash
+            [ BA.pack . BS.unpack . C.pack . T.unpack $
+              T.pack newPin <> session tx :: BA.Bytes
+            ]
     insert_
       "users"
       [ "address" =: address tx
       , "session" =: session tx
       , "blocktime" =: blocktime tx
-      , "pin" =: newPin
+      , "pin" =:
+        (T.pack . show $ (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
       , "validated" =: False
       ]
 
@@ -790,6 +822,10 @@ routes pipe config = do
   post "/api/validateuser" $ do
     providedPin <- param "pin"
     sess <- param "session"
+    let pinHash =
+          BLK.hash
+            [ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes
+            ]
     user <- liftAndCatchIO $ run (findUser sess)
     case user of
       Nothing -> status noContent204 --`debug` "No user match"
@@ -798,7 +834,10 @@ routes pipe config = do
         case parsedUser of
           Nothing -> status noContent204 --`debug` "Couldn't parse user"
           Just pUser -> do
-            let ans = upin pUser == T.pack providedPin
+            let ans =
+                  upin pUser ==
+                  (T.pack . show $
+                   (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
             if ans
               then do
                 liftAndCatchIO $ run (validateUser sess)
@@ -1010,6 +1049,23 @@ routes pipe config = do
     oId <- param "id"
     liftAndCatchIO $ run (deleteOrder oId)
     status ok200
+  -- Get language for component
+  get "/api/getlang" $ do
+    component <- param "component"
+    lang <- param "lang"
+    txtPack' <- liftAndCatchIO $ run (findLangComponent lang component)
+    let txtPack = cast' . Doc =<< txtPack'
+    case txtPack of
+      Nothing -> status noContent204
+      Just tP -> do
+        status ok200
+        Web.Scotty.json $ toJSON (tP :: LangComponent)
+  post "/api/setlang" $ do
+    langComp <- jsonData
+    _ <-
+      liftAndCatchIO $
+      mapM (run . loadLangComponent) (langComp :: [LangComponent])
+    status created201
 
 -- | Make a Zcash RPC call
 makeZcashCall ::
@@ -1106,9 +1162,19 @@ scanZcash config pipe = do
 -- | Function to filter transactions
 isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
 isRelevant re t
-  | zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
+  | zconfirmations t < 100 && (matchTest re . T.unpack . zmemo) t = True
   | otherwise = False
 
+-- | New function to scan transactions with parser
+scanZcash' :: Config -> Pipe -> IO ()
+scanZcash' config pipe = do
+  myTxs <-
+    listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
+  case myTxs of
+    Right txs -> mapM_ (zToZGoTx' config pipe) txs
+    Left e -> do
+      putStrLn $ "Error scanning node transactions: " ++ T.unpack e
+
 -- | Function to scan loaded viewing keys for payments
 scanPayments :: Config -> Pipe -> IO ()
 scanPayments config pipe = do
@@ -1159,6 +1225,7 @@ scanPayments config pipe = do
                              (qexternalInvoice xO)
                              (qaddress xO)
                              (qtotal xO)
+                             (qtotalZec xO)
                      "WC" -> do
                        let wOwner = fst $ head sResult ! 2
                        wooT <-
@@ -1261,42 +1328,55 @@ payOwner p d x =
               let parsedUser = parseUserBson =<< user
               let zaddy = maybe "" uaddress parsedUser
               owner <- access pipe master db $ findOwner zaddy
-              let ownerId = o_id =<< (cast' . Doc) =<< owner
-              if pdelta pmt > 90000000
-                then do
-                  _ <-
-                    access
-                      pipe
-                      master
-                      db
-                      (modify
-                         (select ["_id" =: ownerId] "owners")
-                         [ "$set" =:
-                           [ "paid" =: True
-                           , "invoices" =: True
-                           , "expiration" =:
-                             posixSecondsToUTCTime
-                               (fromInteger
-                                  (pblocktime pmt + pdelta pmt - 90000000))
-                           ]
-                         ])
-                  markPaymentDone pipe db pmt
-                else do
-                  _ <-
-                    access
-                      pipe
-                      master
-                      db
-                      (modify
-                         (select ["_id" =: ownerId] "owners")
-                         [ "$set" =:
-                           [ "paid" =: True
-                           , "expiration" =:
-                             posixSecondsToUTCTime
-                               (fromInteger (pblocktime pmt + pdelta pmt))
-                           ]
-                         ])
-                  markPaymentDone pipe db pmt
+              let foundOwner = (cast' . Doc) =<< owner
+              case foundOwner of
+                Nothing -> error "Couldn't find owner to mark as paid"
+                Just fOwn -> do
+                  if pdelta pmt > 90000000
+                    then do
+                      _ <-
+                        access
+                          pipe
+                          master
+                          db
+                          (modify
+                             (select ["_id" =: o_id fOwn] "owners")
+                             [ "$set" =:
+                               [ "paid" =: True
+                               , "invoices" =: True
+                               , "expiration" =:
+                                 calculateExpiration
+                                   fOwn
+                                   (pdelta pmt - 90000000)
+                                   (pblocktime pmt)
+                               ]
+                             ])
+                      markPaymentDone pipe db pmt
+                    else do
+                      _ <-
+                        access
+                          pipe
+                          master
+                          db
+                          (modify
+                             (select ["_id" =: o_id fOwn] "owners")
+                             [ "$set" =:
+                               [ "paid" =: True
+                               , "expiration" =:
+                                 calculateExpiration
+                                   fOwn
+                                   (pdelta pmt)
+                                   (pblocktime pmt)
+                               ]
+                             ])
+                      markPaymentDone pipe db pmt
+            calculateExpiration :: Owner -> Integer -> Integer -> UTCTime
+            calculateExpiration o delta blocktime =
+              if opaid o
+                then addUTCTime
+                       (secondsToNominalDiffTime (fromIntegral delta))
+                       (oexpiration o)
+                else posixSecondsToUTCTime (fromIntegral $ delta + blocktime)
 
 expireOwners :: Pipe -> T.Text -> IO ()
 expireOwners pipe db = do

src/ZGoTx.hs

@@ -6,9 +6,15 @@ module ZGoTx where
 
 import Data.Aeson
 import qualified Data.Bson as B
+import Data.Char
+import Data.Maybe
 import qualified Data.Text as T
+import qualified Data.UUID as U
+import Data.Void
 import Database.MongoDB
 import GHC.Generics
+import Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
 
 -- | Type to model a ZGo transaction
 data ZGoTx =
@@ -92,3 +98,100 @@ instance Val ZGoTx where
           , "txid" =: t
           , "memo" =: m
           ]
+
+-- | Type to represent and parse ZGo memos
+data ZGoMemo =
+  ZGoMemo
+    { m_session :: Maybe U.UUID
+    , m_address :: Maybe T.Text
+    , m_payment :: Bool
+    }
+  deriving (Eq, Show)
+
+data MemoToken
+  = Login !U.UUID
+  | PayMsg !U.UUID
+  | Address !T.Text
+  | Msg !T.Text
+  deriving (Show, Eq)
+
+type Parser = Parsec Void T.Text
+
+pSession :: Parser MemoToken
+pSession = do
+  string "ZGO"
+  pay <- optional $ char 'p'
+  string "::"
+  s <- some $ hexDigitChar <|> char '-'
+  let u = U.fromString s
+  case u of
+    Nothing -> fail "Invalid UUID"
+    Just u' -> do
+      if isJust pay
+        then pure $ PayMsg u'
+        else pure $ Login u'
+
+pSaplingAddress :: Parser MemoToken
+pSaplingAddress = do
+  string "zs"
+  a <- some alphaNumChar
+  if length a /= 76
+    then fail "Failed to parse Sapling address"
+    else pure $ Address $ T.pack ("zs" <> a)
+
+pMsg :: Parser MemoToken
+pMsg = do
+  Msg . T.pack <$>
+    some
+      (alphaNumChar <|> punctuationChar <|> symbolChar <|>
+       charCategory OtherSymbol)
+
+pMemo :: Parser MemoToken
+pMemo = do
+  optional spaceChar
+  pSession <|> pSaplingAddress <|> pMsg
+
+isMemoToken :: T.Text -> MemoToken -> Bool
+isMemoToken kind t =
+  case kind of
+    "session" ->
+      case t of
+        PayMsg i -> True
+        Login j -> True
+        _ -> False
+    "address" ->
+      case t of
+        Address a -> True
+        _ -> False
+    "payment" ->
+      case t of
+        PayMsg i -> True
+        _ -> False
+    _ -> False
+
+pZGoMemo :: Parser ZGoMemo
+pZGoMemo = do
+  tks <- some pMemo
+  pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks)
+  where
+    isPayment [] = False
+    isPayment tks =
+      not (null tks) &&
+      case head tks of
+        PayMsg x -> True
+        _ -> isPayment $ tail tks
+    isAddress [] = Nothing
+    isAddress tks =
+      if not (null tks)
+        then case head tks of
+               Address x -> Just x
+               _ -> isAddress $ tail tks
+        else Nothing
+    isSession [] = Nothing
+    isSession tks =
+      if not (null tks)
+        then case head tks of
+               Login x -> Just x
+               PayMsg y -> Just y
+               _ -> isSession $ tail tks
+        else Nothing

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-19.33
+resolver: lts-20.8
   #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
 
 # User packages to be built.
@@ -45,6 +45,7 @@ extra-deps:
   - git: https://github.com/reach-sh/haskell-hexstring.git
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
   - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
+  - crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

stack.yaml.lock

@@ -22,9 +22,16 @@ packages:
       size: 1433
   original:
     hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
+- completed:
+    hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
+    pantry-tree:
+      sha256: 1caccafe35d1ae3063f057c31188742a8e794f4f4e4530bab4019c0a514ee54f
+      size: 455
+  original:
+    hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565
 snapshots:
 - completed:
-    sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4
-    size: 619204
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml
-  original: lts-19.33
+    sha256: bfafe5735ccb74527d754b1f9999ded72d7c3a6c3a88529449661431ccfbd6cc
+    size: 649327
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/8.yaml
+  original: lts-20.8

test/Spec.hs

@@ -19,6 +19,7 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Database.MongoDB
 import Item
+import LangComponent
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
 import Order
@@ -139,7 +140,8 @@ main = do
               "\128737MSG\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e\n\nZGOp::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
       describe "PIN generator" $ do
         it "should give a 7 digit" $ do
-          length (T.unpack (unsafePerformIO (generatePin 1010))) `shouldBe` 7
+          pin <- generatePin
+          length pin `shouldBe` 7
     describe "API endpoints" $ do
       beforeAll_ (startAPI loadedConfig) $ do
         describe "Price endpoint" $ do
@@ -256,7 +258,7 @@ main = do
             req <-
               testPost
                 "/api/wootoken"
-                [("ownerid", Just "627ad3492b05a76be5000001")]
+                [("ownerid", Just "627ad3492b05a76be3000001")]
             res <- httpLBS req
             getResponseStatus res `shouldBe` accepted202
           it "authenticate with incorrect owner" $ do
@@ -264,7 +266,9 @@ main = do
               testPublicGet
                 "/auth"
                 [ ("ownerid", Just "62cca13f5530331e2a900001")
-                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ( "token"
+                  , Just
+                      "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
                 , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
                 ]
             res <- httpJSON req
@@ -284,7 +288,9 @@ main = do
               testPublicGet
                 "/auth"
                 [ ("ownerid", Just "627ad3492b05a76be3000001")
-                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ( "token"
+                  , Just
+                      "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
                 , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
                 ]
             res <- httpJSON req
@@ -294,7 +300,9 @@ main = do
               testPublicGet
                 "/auth"
                 [ ("ownerid", Just "627ad3492b05a76be3000001")
-                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ( "token"
+                  , Just
+                      "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
                 , ("siteurl", Just "aHR0cHM6Ly93d3cuZ29vZ2xlLmNvbS8")
                 ]
             res <- httpJSON req
@@ -304,7 +312,9 @@ main = do
               testPublicGet
                 "/woopayment"
                 [ ("ownerid", Just "627ad3492b05a76be3000001")
-                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ( "token"
+                  , Just
+                      "0c1702c16c7bd7e075b8bb129b24888a5cc2181fa1eb4ce9190cfcb625ecf0ee")
                 , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
                 , ("order_id", Just "1234")
                 , ("currency", Just "usd")
@@ -314,6 +324,28 @@ main = do
                 ]
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+        describe "Language endpoint" $ do
+          it "existing component" $ do
+            req <-
+              testGet
+                "/api/getlang"
+                [("lang", Just "en-US"), ("component", Just "login")]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "wrong component" $ do
+            req <-
+              testGet
+                "/api/getlang"
+                [("lang", Just "en-US"), ("component", Just "test")]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` noContent204
+          it "wrong language" $ do
+            req <-
+              testGet
+                "/api/getlang"
+                [("lang", Just "fr-FR"), ("component", Just "login")]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` noContent204
     around handleDb $
       describe "Database actions" $ do
         describe "authentication" $ do
@@ -441,7 +473,7 @@ main = do
             let s = parseZGoTxBson =<< t
             let conf = maybe 0 confirmations s
             conf `shouldSatisfy` (> 0)
-          xit "payments are added to db" $ \p -> do
+          it "payments are added to db" $ \p -> do
             _ <-
               access
                 p
@@ -454,7 +486,7 @@ main = do
             let s = (cast' . Doc) =<< t
             let payDelta = maybe 0 pdelta s
             payDelta `shouldSatisfy` (> 0)
-          xit "owners are marked as paid" $ \p -> do
+          it "owners are marked as paid" $ \p -> do
             let myUser =
                   User
                     (Just (read "6272a90f2b05a74cf1000002" :: ObjectId))
@@ -658,7 +690,7 @@ startAPI config = do
           "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
           "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
           1613487
-          "1234567"
+          "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
           False
   _ <-
     access
@@ -697,34 +729,7 @@ startAPI config = do
           True
           False
           False
-          (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
-          False
-          ""
-          ""
-  let myOwner1 =
-        Owner
-          (Just (read "627ad3492b05a76be5000001"))
-          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
-          "Test shop"
-          "usd"
-          False
-          0
-          False
-          0
-          "Bubba"
-          "Gibou"
-          "bubba@zgo.cash"
-          "1 Main St"
-          "Mpls"
-          "Minnesota"
-          "55401"
-          ""
-          "bubbarocks.io"
-          "United States"
-          True
-          False
-          False
-          (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
+          (UTCTime (fromGregorian 2023 2 6) (secondsToDiffTime 0))
           False
           ""
           ""
@@ -765,16 +770,16 @@ startAPI config = do
   case itemTest of
     Doc iT -> access pipe master "test" (insert_ "items" iT)
     _ -> fail "Couldn't save test Item in DB"
-  let myWooToken =
-        WooToken
-          Nothing
-          (read "627ad3492b05a76be3000001")
-          "89bd9d8d69a674e0f467cc8796ed151a"
-          Nothing
-  let wooTest = val myWooToken
-  case wooTest of
-    Doc wT -> access pipe master "test" (insert_ "wootokens" wT)
-    _ -> fail "Couldn't save test WooToken in DB"
+  --let myWooToken =
+        --WooToken
+          --Nothing
+          --(read "627ad3492b05a76be3000001")
+          --"89bd9d8d69a674e0f467cc8796ed151a"
+          --Nothing
+  --let wooTest = val myWooToken
+  --case wooTest of
+    --Doc wT -> access pipe master "test" (insert_ "wootokens" wT)
+    --_ -> fail "Couldn't save test WooToken in DB"
   threadDelay 1000000
   putStrLn "Test server is up!"
 

zgo-backend.cabal

@@ -5,13 +5,13 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           zgo-backend
-version:        1.1.1
+version:        1.3.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>
+description:    Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
 category:       Web
 author:         Rene Vergara
 maintainer:     rene@vergara.network
-copyright:      Copyright (c) 2022 Vergara Technologies LLC
+copyright:      Copyright (c) 2023 Vergara Technologies LLC
 license:        BOSL
 license-file:   LICENSE
 build-type:     Simple
@@ -22,12 +22,13 @@ extra-source-files:
 
 source-repository head
   type: git
-  location: https://gitlab.com/pitmutt/zgo-backend
+  location: https://git.vergara.tech/Vergara_Tech/zgo-backend
 
 library
   exposed-modules:
       Config
       Item
+      LangComponent
       Order
       Owner
       Payment
@@ -51,13 +52,16 @@ library
     , bytestring
     , configurator
     , containers
+    , crypto-rng
     , ghc-prim
     , hexstring
     , http-conduit
     , http-types
     , jwt
+    , megaparsec
     , memory
     , mongoDB
+    , network
     , quickcheck-instances
     , random
     , regex-base
@@ -68,6 +72,7 @@ library
     , text
     , time
     , unordered-containers
+    , uuid
     , vector
     , wai
     , wai-cors
@@ -78,6 +83,7 @@ library
 executable zgo-backend-exe
   main-is: Server.hs
   other-modules:
+      Tasks
       TokenRefresh
       Paths_zgo_backend
   hs-source-dirs:
@@ -90,6 +96,7 @@ executable zgo-backend-exe
     , configurator
     , http-conduit
     , http-types
+    , megaparsec
     , mongoDB
     , scotty
     , securemem
@@ -101,10 +108,31 @@ executable zgo-backend-exe
     , zgo-backend
   default-language: Haskell2010
 
+executable zgo-tasks
+  main-is: Tasks.hs
+  other-modules:
+      Server
+      TokenRefresh
+      Paths_zgo_backend
+  hs-source-dirs:
+      app
+  ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall
+  build-depends:
+      base
+    , megaparsec
+    , mongoDB
+    , scotty
+    , time
+    , warp
+    , warp-tls
+    , zgo-backend
+  default-language: Haskell2010
+
 executable zgo-token-refresh
   main-is: TokenRefresh.hs
   other-modules:
       Server
+      Tasks
       Paths_zgo_backend
   hs-source-dirs:
       app
@@ -116,6 +144,7 @@ executable zgo-token-refresh
     , configurator
     , http-conduit
     , http-types
+    , megaparsec
     , mongoDB
     , scotty
     , securemem

zgo.cfg

@@ -10,3 +10,7 @@ port = 3000
 tls = false
 certificate = "/path/to/cert.pem"
 key = "/path/to/key.pem"
+smtpHost = "127.0.0.1"
+smtpPort = 1025
+smtpUser = "contact@zgo.cash"
+smtpPwd = "uib3K8BkCPexl_wr5bYfrg"

zgotest.cfg

@@ -10,3 +10,7 @@ port = 3000
 tls = false
 certificate = "/path/to/cert.pem"
 key = "/path/to/key.pem"
+smtpHost = "127.0.0.1"
+smtpPort = 1025
+smtpUser = "contact@zgo.cash"
+smtpPwd = "uib3K8BkCPexl_wr5bYfrg"