mateamt/src/Control/User.hs
2022-07-17 21:28:22 +02:00

254 lines
6.7 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
now <- liftIO getCurrentTime
conn <- asks rsConnection
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 =
throwError $ err401
{ errBody = "No Authentication present."
}
userGet (Just (uid, _)) = do
conn <- asks rsConnection
userDetailsSelect uid conn
userGetAll
:: Maybe (Int, AuthMethod)
-> MateHandler [UserDetails]
userGetAll Nothing =
throwError $ err401
{ errBody = "No Authentication present."
}
userGetAll (Just (_, _)) = do
conn <- asks rsConnection
userDetailsSelectAll conn
userUpdate
:: Maybe (Int, AuthMethod)
-> UserDetailsSubmit
-> MateHandler NoContent
userUpdate Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
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
throwError $ err401
{ errBody = "Wrong Authentication present."
}
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 =
throwError $ err401
{ errBody = "No Authentication present."
}
userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
userList ref = do
conn <- asks rsConnection
userSelect (fromMaybe ActiveUsers ref) 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 _ =
throwError $ err401
{ errBody = "No Authentication present."
}
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]) $
throwError $ err401
{ errBody = "No Authentication present."
}
conn <- asks rsConnection
user <- userDetailsSelect auid conn
when (amount > userDetailsBalance user) $
throwError $ err400
{ errBody = "Not enough credit balance."
}
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers 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 _ =
throwError $ err401
{ errBody = "No Authentication present."
}
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 _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}