mateamt/src/Control/User.hs

140 lines
3.4 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)
import Control.Monad.Reader (ask)
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
-- internal imports
import Types
import Model
2019-09-15 12:59:22 +00:00
userNew
:: UserSubmit
-> MateHandler Int
userNew (UserSubmit ident email passhash) = do
2019-08-14 16:04:16 +00:00
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
uid <- insertUser ident email (utctDay now) conn
2019-09-16 06:59:57 +00:00
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash 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
conn <- rsConnection <$> ask
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 =
if any (== method) [PrimaryPass, ChallengeResponse]
2019-08-14 16:04:16 +00:00
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
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-09-15 12:59:22 +00:00
userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
2019-09-09 10:53:07 +00:00
userList ref = do
2019-08-14 16:04:16 +00:00
conn <- rsConnection <$> ask
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) =
2019-09-06 19:43:46 +00:00
if amount >= 0
then do
conn <- rsConnection <$> ask
ud <- userDetailsSelect auid conn
void $ insertNewJournalEntry
(JournalSubmit
("User \"" <> userDetailsIdent ud <> "\" recharged " <>
T.pack (show (fromIntegral amount / 100 :: Double)))
amount
)
conn
void $ addToUserBalance auid amount conn
else
throwError $ err400
{ errBody = "Amounts less or equal zero are not acceptable."
}
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) =
2019-09-06 19:43:46 +00:00
if amount >= 0
2019-08-14 16:04:16 +00:00
then
2019-09-06 19:43:46 +00:00
if auid /= target
2019-09-15 12:59:22 +00:00
then
if any (== method) [PrimaryPass, ChallengeResponse]
2019-09-06 19:43:46 +00:00
then do
2019-09-15 12:59:22 +00:00
conn <- rsConnection <$> ask
user <- userDetailsSelect auid conn
if amount < userDetailsBalance user
2019-09-06 19:43:46 +00:00
then do
2019-09-15 12:59:22 +00:00
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
if not (null mtarget)
then do
void $ addToUserBalance auid (-amount) conn
void $ addToUserBalance target amount conn
else
throwError $ err400
{ errBody = "Target user not found."
}
2019-09-06 19:43:46 +00:00
else
2019-09-15 12:59:22 +00:00
throwError $ err400
{ errBody = "Not enough credit balance."
}
2019-09-06 19:43:46 +00:00
else
2019-09-15 12:59:22 +00:00
throwError $ err400
{ errBody = "You can not transfer yourself money."
}
2019-09-06 19:43:46 +00:00
else
2019-09-15 12:59:22 +00:00
throwError $ err401
{ errBody = "No Authentication present."
2019-09-06 19:43:46 +00:00
}
2019-08-14 16:04:16 +00:00
else
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
}
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
}