zgo-backend/src/User.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}

module User where

import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Bson as B
import Data.Maybe
import qualified Data.Text as T
import Database.MongoDB
import GHC.Generics
import System.IO.Unsafe
import System.Random
import ZGoTx

-- | Type to represent a ZGo User, i.e.: a specific device
data User =
  User
    { u_id :: Maybe ObjectId
    , uaddress :: T.Text
    , usession :: T.Text
    , ublocktime :: Integer
    , upin :: T.Text
    , uvalidated :: Bool
    }
  deriving (Eq, Show, Generic)

instance ToJSON User where
  toJSON (User i a s bt p v) =
    case i of
      Just oid ->
        object
          [ "_id" .= show oid
          , "address" .= a
          , "session" .= s
          , "blocktime" .= bt
          , "validated" .= v
          ]
      Nothing ->
        object
          [ "_id" .= ("" :: String)
          , "address" .= a
          , "session" .= s
          , "blocktime" .= bt
          , "validated" .= v
          ]

instance FromJSON User where
  parseJSON =
    withObject "User" $ \obj -> do
      i <- obj .: "_id"
      a <- obj .: "address"
      s <- obj .: "session"
      bt <- obj .: "blocktime"
      v <- obj .: "validated"
      pure $
        User
          (if not (null i)
             then Just (read i)
             else Nothing)
          a
          s
          bt
          ""
          v

parseUserBson :: B.Document -> Maybe User
parseUserBson d = do
  i <- B.lookup "_id" d
  a <- B.lookup "address" d
  s <- B.lookup "session" d
  b <- B.lookup "blocktime" d
  p <- B.lookup "pin" d
  v <- B.lookup "validated" d
  pure $ User i a s b p v

-- Database Actions
-- | Function to query DB for unexpired user by session ID
findUser :: T.Text -> Action IO (Maybe Document)
findUser s = findOne (select ["session" =: s] "users")

-- | Function to delete user by ID
deleteUser :: String -> Action IO ()
deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")

-- | Function to verify if the given ZGoTx represents an already existing User
isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
isUserNew p db tx =
  isNothing <$>
  access p master db (findOne (select ["session" =: session tx] "users"))

-- | Function to mark user as validated
validateUser :: T.Text -> Action IO ()
validateUser session =
  modify
    (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)

-- | Helper function to pad a string to a given length
padLeft :: String -> Char -> Int -> String
padLeft s c m =
  let isBaseLarger = length s > m
      padder st ch m False = [ch | _ <- [1 .. (m - length st)]] ++ s
      padder st _ _ True = st
   in padder s c m isBaseLarger