zgo-backend/src/User.hs
2022-07-25 12:29:02 -05:00

115 lines
2.9 KiB
Haskell

{-# 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