96 lines
2.5 KiB
Haskell
96 lines
2.5 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 :: String
|
||
|
|
, 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) =
|
||
|
|
object
|
||
|
|
[ "_id" .= i
|
||
|
|
, "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 i 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 (show (i :: B.ObjectId)) 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 :: IO T.Text
|
||
|
|
generatePin = do
|
||
|
|
g <- newStdGen
|
||
|
|
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
|