{-# 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 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 _ = 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." } -- 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 _ = 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." }