{-# 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