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)
|
|
|
|
|
2019-09-11 02:04:06 +00:00
|
|
|
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
|
2019-09-15 14:11:56 +00:00
|
|
|
userNew (UserSubmit ident email passhash) = do
|
2019-08-14 16:04:16 +00:00
|
|
|
now <- liftIO $ getCurrentTime
|
|
|
|
conn <- rsConnection <$> ask
|
2019-09-15 14:11:56 +00:00
|
|
|
uid <- insertUser ident email (utctDay now) conn
|
2019-09-16 06:59:57 +00:00
|
|
|
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
|
2019-09-15 14:11:56 +00:00
|
|
|
return uid
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userGet
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler UserDetails
|
2019-10-14 15:39:28 +00:00
|
|
|
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
|
|
|
}
|
2019-10-14 15:39:28 +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
|
2019-09-11 02:04:06 +00:00
|
|
|
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
|
|
|
}
|