115 lines
2.9 KiB
Haskell
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
|