mateamt/src/Control/User.hs

244 lines
6.5 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Control.User where
import Servant
import Control.Monad (void, when)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Crypto.Error
import Data.String (fromString)
import Data.Text.Encoding
import Data.Time (getCurrentTime, utctDay)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Text.Printf (printf)
-- internal imports
import Types
import Model
import Util
import Util.Crypto
userNew
:: UserSubmit
-> MateHandler Int
userNew (UserSubmit ident email pass) = do
conn <- asks rsConnection
block <- selectSignupBlocked conn
if block
then
throwError $ err401
{ errBody = "User registration has been disabled"
}
else do
now <- liftIO getCurrentTime
uid <- insertUser ident email (utctDay now) conn
salt <- liftIO randomString
let mpasshash = argon2 salt (encodeUtf8 pass)
case mpasshash of
CryptoPassed passhash -> do
liftIO $ print passhash
void $ putUserAuthInfo uid PrimaryPass "Initial password" salt passhash conn
CryptoFailed err ->
throwError $ err500
{ errBody = "Crypto error: " <> fromString (show err)
}
baseRoleId <- queryRoleIdByCapabilities
(False, False, False, False, False, False, False, False, False, False)
conn
void $ associateUserToRole uid baseRoleId conn
return uid
userGet
:: Maybe (Int, AuthMethod)
-> MateHandler UserDetails
userGet Nothing =
throwMissingAuth
userGet (Just (uid, _)) = do
conn <- asks rsConnection
userDetailsSelect uid conn
userGetAll
:: Maybe (Int, AuthMethod)
-> MateHandler [UserDetails]
userGetAll Nothing =
throwMissingAuth
userGetAll (Just (_, _)) = do
conn <- asks rsConnection
userDetailsSelectAll conn
userUpdate
:: Maybe (Int, AuthMethod)
-> UserDetailsSubmit
-> MateHandler NoContent
userUpdate Nothing _ =
throwMissingAuth
userUpdate (Just (aid, method)) uds =
if method `elem` [PrimaryPass, ChallengeResponse]
then do
now <- liftIO getCurrentTime
conn <- asks rsConnection
void $ updateUserDetails aid uds (utctDay now) conn
return NoContent
else
throwWrongAuth
userUpdateTimestamp
:: Maybe (Int, AuthMethod)
-> MateHandler NoContent
userUpdateTimestamp (Just (aid, _)) = do
now <- liftIO getCurrentTime
conn <- asks rsConnection
void $ updateUserTimestamp aid (utctDay now) conn
return NoContent
userUpdateTimestamp Nothing =
throwMissingAuth
userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
userList ref = do
conn <- asks rsConnection
idleTime <- selectIdleTime conn
userSelect (fromMaybe ActiveUsers ref) idleTime conn
userRecharge
:: Maybe (Int, AuthMethod)
-> UserRecharge
-> MateHandler NoContent
userRecharge (Just (auid, _)) (UserRecharge amount) = do
when (amount < 0) $
throwError $ err400
{ errBody = "Amounts less or equal zero are not acceptable."
}
conn <- asks rsConnection
ud <- userDetailsSelect auid conn
void $ insertNewJournalEntry
(JournalSubmit
(Just $ userDetailsId ud)
Recharge
amount
)
conn
void $ addToUserBalance auid amount conn
return NoContent
userRecharge Nothing _ =
throwMissingAuth
userTransfer
:: Maybe (Int, AuthMethod)
-> UserTransfer
-> MateHandler NoContent
userTransfer (Just (auid, method)) (UserTransfer target amount) = do
when (amount < 0) $
throwError $ err400
{ errBody = "Amounts less or equal zero are not acceptable."
}
when (auid == target) $
throwError $ err400
{ errBody = "You can not transfer yourself money."
}
when (method `notElem` [PrimaryPass, ChallengeResponse]) throwWrongAuth
conn <- asks rsConnection
user <- userDetailsSelect auid conn
when (amount > userDetailsBalance user) $
throwError $ err400
{ errBody = "Not enough credit balance."
}
-- Here, userSelect is called with a idle Time of 0, since it selects All users
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers 0 conn
when (null mtarget) $
throwError $ err400
{ errBody = "Target user not found."
}
void $ addToUserBalance auid (-amount) conn
void $ addToUserBalance target amount conn
return NoContent
userTransfer Nothing _ =
throwMissingAuth
userNotify
:: Maybe (Int, AuthMethod)
-> [PurchaseDetail]
-> PurchaseResult
-> MateHandler NoContent
userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
conn <- asks rsConnection
authOV <- selectAuthOverviewById auid conn
userDetails <- userDetailsSelect (authOverviewUser authOV) conn
digestedDetails <- mapM
(\pd -> do
overview <- productOverviewSelectSingle (purchaseDetailProduct pd) conn
return
( purchaseDetailAmount pd
, productOverviewIdent overview
, productOverviewPrice overview
)
)
boughtItems
currencyFrac <- asks rsCurrencyFraction
currencySymb <- asks rsCurrencySymbol
let messageText = T.pack $ mconcat $ map (<> "\n") $
[ printf (__ "Hello %s,") (userDetailsIdent userDetails)
, ""
, printf (__ "Your authentication key with the comment \"%s\"\
\ Just made following purchase:")
(authOverviewComment authOV)
, ""
] ++
map
(\(amount, ident, price) ->
printf
("%dx %s " <>
__ "for the price of" <>
"%d %f." <>
printf "%d" currencyFrac <>
printf "%s" currencySymb
)
amount
ident
price
)
digestedDetails
++
[ ""
, printf (__ "For a total price of %s%s") <>
printf
("%f." <>
(printf "%d" currencyFrac :: String))
(fromIntegral (
foldl (\acc (_, _, p) -> acc + p)
0
digestedDetails
) /
fromIntegral (10 ^ currencyFrac :: Int)
:: Float )
currencySymb
, ""
, __ "Enjoy your purchased items!\n\nSincerely,\nMateamt"
] ++
[ __ "P.S.: You are now in debt. Please recharge your credit." |
flag == PurchaseDebtful ]
case userDetailsEmail userDetails of
Just _ -> do
sendUserNotification
userDetails
(__ "Purchase notification")
messageText
return NoContent
Nothing ->
return NoContent
userNotify Nothing _ _ =
throwMissingAuth