mateamt/src/Control/User.hs

222 lines
5.9 KiB
Haskell
Raw Normal View History

2019-08-14 16:04:16 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Control.User where
import Servant
import Control.Monad (void, when)
2019-08-14 16:04:16 +00:00
2019-10-14 20:50:42 +00:00
import Control.Monad.Reader (asks)
2019-08-14 16:04:16 +00:00
import Control.Monad.IO.Class (liftIO)
import Data.Time (getCurrentTime, utctDay)
import Data.Maybe (fromMaybe)
2019-08-14 16:04:16 +00:00
import qualified Data.Text as T
2021-06-24 04:33:05 +00:00
import Text.Printf (printf)
2019-08-14 16:04:16 +00:00
-- internal imports
import Types
import Model
2021-06-24 04:33:05 +00:00
import Util
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
userNew
:: UserSubmit
-> MateHandler Int
userNew (UserSubmit ident email passhash) = do
2019-10-14 20:50:42 +00:00
now <- liftIO getCurrentTime
conn <- asks rsConnection
uid <- insertUser ident email (utctDay now) conn
2019-09-16 06:59:57 +00:00
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
baseRoleId <- queryRoleIdByCapabilities
(False, False, False, False, False, False, False, False, False, False)
2020-07-19 10:27:28 +00:00
conn
void $ associateUserToRole uid baseRoleId conn
return uid
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
userGet
:: Maybe (Int, AuthMethod)
-> MateHandler UserDetails
userGet Nothing =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-06 19:44:31 +00:00
{ errBody = "No Authentication present."
2019-08-14 16:04:16 +00:00
}
userGet (Just (uid, _)) = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
userDetailsSelect uid conn
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
userUpdate
:: Maybe (Int, AuthMethod)
-> UserDetailsSubmit
-> MateHandler ()
2019-09-16 06:59:57 +00:00
userUpdate Nothing _ =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-06 19:44:31 +00:00
{ errBody = "No Authentication present."
2019-08-14 16:04:16 +00:00
}
2019-09-16 06:59:57 +00:00
userUpdate (Just (aid, method)) uds =
2019-10-14 21:34:45 +00:00
if method `elem` [PrimaryPass, ChallengeResponse]
2019-08-14 16:04:16 +00:00
then do
2019-10-14 20:50:42 +00:00
now <- liftIO getCurrentTime
conn <- asks rsConnection
2019-09-16 06:59:57 +00:00
void $ updateUserDetails aid uds (utctDay now) conn
2019-08-14 16:04:16 +00:00
else
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-06 19:44:31 +00:00
{ errBody = "Wrong Authentication present."
2019-08-14 16:04:16 +00:00
}
2019-12-26 08:26:32 +00:00
userUpdateTimestamp
:: Maybe (Int, AuthMethod)
-> MateHandler ()
userUpdateTimestamp (Just (aid, _)) = do
now <- liftIO getCurrentTime
conn <- asks rsConnection
void $ updateUserTimestamp aid (utctDay now) conn
userUpdateTimestamp Nothing =
throwError $ err401
{ errBody = "No Authentication present."
}
2019-09-15 12:59:22 +00:00
userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
2019-09-09 10:53:07 +00:00
userList ref = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
userSelect (fromMaybe ActiveUsers ref) conn
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
userRecharge
:: Maybe (Int, AuthMethod)
-> UserRecharge
-> MateHandler ()
userRecharge (Just (auid, _)) (UserRecharge amount) = do
2020-05-10 08:06:10 +00:00
when (amount < 0) $
2019-09-06 19:43:46 +00:00
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
2019-09-06 19:43:46 +00:00
userRecharge Nothing _ =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-06 19:43:46 +00:00
{ errBody = "No Authentication present."
}
2019-09-15 12:59:22 +00:00
userTransfer
:: Maybe (Int, AuthMethod)
-> UserTransfer
-> MateHandler ()
userTransfer (Just (auid, method)) (UserTransfer target amount) = do
2020-05-10 08:06:10 +00:00
when (amount < 0) $
2019-09-06 19:44:31 +00:00
throwError $ err400
{ errBody = "Amounts less or equal zero are not acceptable."
2019-08-14 16:04:16 +00:00
}
2020-05-10 08:06:10 +00:00
when (auid == target) $
throwError $ err400
{ errBody = "You can not transfer yourself money."
}
2020-05-10 08:06:10 +00:00
when (method `notElem` [PrimaryPass, ChallengeResponse]) $
throwError $ err401
{ errBody = "No Authentication present."
}
conn <- asks rsConnection
user <- userDetailsSelect auid conn
2020-05-10 08:06:10 +00:00
when (amount > userDetailsBalance user) $
throwError $ err400
{ errBody = "Not enough credit balance."
}
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
2020-05-10 08:06:10 +00:00
when (null mtarget) $
throwError $ err400
{ errBody = "Target user not found."
}
void $ addToUserBalance auid (-amount) conn
void $ addToUserBalance target amount conn
2019-09-06 19:43:46 +00:00
userTransfer Nothing _ =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-06 19:43:46 +00:00
{ errBody = "No Authentication present."
2019-08-14 16:04:16 +00:00
}
2021-02-15 18:00:29 +00:00
userNotify
:: Maybe (Int, AuthMethod)
-> [PurchaseDetail]
-> PurchaseResult
-> MateHandler ()
2021-07-14 01:08:58 +00:00
userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
2021-06-10 15:54:57 +00:00
conn <- asks rsConnection
2021-06-16 16:09:08 +00:00
authOV <- selectAuthOverviewById auid conn
userDetails <- userDetailsSelect (authOverviewUser authOV) conn
2021-06-10 15:54:57 +00:00
digestedDetails <- mapM
(\pd -> do
2021-06-16 16:09:08 +00:00
overview <- productOverviewSelectSingle (purchaseDetailProduct pd) conn
2021-07-02 20:53:09 +00:00
return
( purchaseDetailAmount pd
, productOverviewIdent overview
, productOverviewPrice overview
)
2021-06-10 15:54:57 +00:00
)
boughtItems
2021-07-12 11:29:40 +00:00
currencyFrac <- asks rsCurrencyFraction
2021-07-02 20:53:09 +00:00
currencySymb <- asks rsCurrencySymbol
2021-07-14 01:08:58 +00:00
let messageText = T.pack $ mconcat $ map (<> "\n") $
2021-06-24 04:33:05 +00:00
[ printf (__ "Hello %s,") (userDetailsIdent userDetails)
, ""
, printf (__ "Your authentication key with the comment \"%s\"\
\ Just made following purchase:")
(authOverviewComment authOV)
2021-06-10 15:54:57 +00:00
, ""
2021-07-02 20:53:09 +00:00
] ++
2021-07-14 01:08:58 +00:00
map
2021-07-02 20:53:09 +00:00
(\(amount, ident, price) ->
printf
("%dx %s " <>
2021-07-14 01:08:58 +00:00
__ "for the price of" <>
2021-07-02 20:53:09 +00:00
"%d %f." <>
2021-07-14 01:08:58 +00:00
printf "%d" currencyFrac <>
printf "%s" currencySymb
2021-07-02 20:53:09 +00:00
)
amount
ident
price
)
2021-07-12 11:29:40 +00:00
digestedDetails
2021-07-02 20:53:09 +00:00
++
[ ""
, printf (__ "For a total price of %s%s") <>
2021-07-14 01:08:58 +00:00
printf
2021-07-12 11:29:40 +00:00
("%f." <>
(printf "%d" currencyFrac :: String))
2021-07-14 01:08:58 +00:00
(fromIntegral (
2021-07-12 11:29:40 +00:00
foldl (\acc (_, _, p) -> acc + p)
0
digestedDetails
) /
2021-07-14 01:08:58 +00:00
fromIntegral (10 ^ currencyFrac :: Int)
:: Float )
2021-07-12 11:29:40 +00:00
currencySymb
, ""
2021-07-14 01:08:58 +00:00
, __ "Enjoy your purchased items!\n\nSincerely,\nMateamt"
] ++
[ __ "P.S.: You are now in debt. Please recharge your credit." |
flag == PurchaseDebtful ]
2021-07-12 11:29:40 +00:00
case userDetailsEmail userDetails of
Just _ -> do
sendUserNotification
userDetails
(__ "Purchase notification")
messageText
Nothing ->
return ()
2021-07-14 01:08:58 +00:00
userNotify Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}