152 lines
3.7 KiB
Haskell
152 lines
3.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
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
|
|
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
|
|
|
|
instance Val User where
|
|
cast' (Doc 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
|
|
Just $ User i a s b p v
|
|
cast' _ = Nothing
|
|
val (User i a s b p v) =
|
|
case i of
|
|
Just oid ->
|
|
Doc
|
|
[ "_id" =: oid
|
|
, "address" =: a
|
|
, "session" =: s
|
|
, "blocktime" =: b
|
|
, "pin" =: p
|
|
, "validated" =: v
|
|
]
|
|
Nothing ->
|
|
Doc
|
|
[ "address" =: a
|
|
, "session" =: s
|
|
, "blocktime" =: b
|
|
, "pin" =: p
|
|
, "validated" =: 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")
|
|
|
|
findUserById :: String -> Action IO (Maybe Document)
|
|
findUserById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "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 verify if the given session has a valid user
|
|
isUserValid :: Pipe -> T.Text -> T.Text -> IO Bool
|
|
isUserValid p db s =
|
|
isJust <$>
|
|
access
|
|
p
|
|
master
|
|
db
|
|
(findOne (select ["session" =: s, "validated" =: True] "users"))
|
|
|
|
-- | Function to mark user as validated
|
|
validateUser :: T.Text -> Action IO ()
|
|
validateUser session =
|
|
modify
|
|
(select ["session" =: session] "users")
|
|
["$set" =: ["validated" =: True]]
|
|
|
|
generatePin :: IO String
|
|
generatePin = do
|
|
rngState <- newCryptoRNGState
|
|
runCryptoRNGT rngState $
|
|
randomString 7 ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
|