aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/SignIn.hs16
-rw-r--r--src/server/Controller/User.hs25
-rw-r--r--src/server/Main.hs9
-rw-r--r--src/server/Model/Database.hs4
-rw-r--r--src/server/Model/Income.hs21
5 files changed, 60 insertions, 15 deletions
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 955ad35..3bbb9ff 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -64,22 +64,22 @@ errorResponse msg = do
jsonObject [("error", Json.String msg)]
validateSignIn :: Config -> Text -> ActionM ()
-validateSignIn config token = do
- maybeSignIn <- liftIO . runDb $ getSignInToken token
+validateSignIn config textToken = do
+ mbToken <- liftIO . runDb $ getSignInToken textToken
now <- liftIO getCurrentTime
- case maybeSignIn of
- Just signIn ->
- if signInIsUsed . entityVal $ signIn
+ case mbToken of
+ Just token ->
+ if signInIsUsed . entityVal $ token
then
redirectError (getMessage SignInUsed)
else
- let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
+ let diffTime = now `diffUTCTime` (signInCreation . entityVal $ token)
in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
then
redirectError (getMessage SignInExpired)
else do
- LoginSession.put (signInEmail . entityVal $ signIn)
- liftIO . runDb . signInTokenToUsed . entityKey $ signIn
+ LoginSession.put (signInEmail . entityVal $ token)
+ liftIO . runDb . signInTokenToUsed . entityKey $ token
redirect "/"
Nothing ->
redirectError (getMessage SignInInvalid)
diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs
index bc99ea5..420a2d9 100644
--- a/src/server/Controller/User.hs
+++ b/src/server/Controller/User.hs
@@ -4,12 +4,17 @@ module Controller.User
( getUsers
, whoAmI
, getIncome
+ , setIncome
) where
import Web.Scotty
+import Network.HTTP.Types.Status (ok200)
+
import Control.Monad.IO.Class (liftIO)
+import Database.Persist
+
import qualified Data.Aeson.Types as Json
import qualified Secure
@@ -18,21 +23,33 @@ import Json (jsonObject)
import Model.Database
import qualified Model.User as U
+import qualified Model.Income as I
getUsers :: ActionM ()
getUsers =
- Secure.loggedAction (\_ -> do
+ Secure.loggedAction (\_ ->
(liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json
)
whoAmI :: ActionM ()
whoAmI =
- Secure.loggedAction (\user -> do
+ Secure.loggedAction (\user ->
json (U.getJsonUser user)
)
getIncome :: ActionM ()
getIncome =
- Secure.loggedAction (\_ -> do
- jsonObject []
+ Secure.loggedAction (\user -> do
+ mbIncome <- liftIO . runDb . I.getIncome $ entityKey user
+ case mbIncome of
+ Just income ->
+ jsonObject [("income", Json.Number . fromIntegral . incomeAmount $ income)]
+ Nothing ->
+ jsonObject []
+ )
+
+setIncome :: Int -> ActionM ()
+setIncome amount =
+ Secure.loggedAction (\user ->
+ (liftIO . runDb $ I.setIncome (entityKey user) amount) >> status ok200
)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 8956fa4..71c4674 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -48,9 +48,12 @@ main = do
-- Users
- get "/users" getUsers
- get "/whoAmI" whoAmI
- get "/income" getIncome
+ get "/users" getUsers
+ get "/whoAmI" whoAmI
+ get "/income" getIncome
+ post "/income" $ do
+ amount <- param "amount" :: ActionM Int
+ setIncome amount
-- Payments
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 0bbc353..c88322f 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -52,6 +52,10 @@ Job
lastExecution UTCTime Maybe
UniqJobName kind
deriving Show
+Income
+ userId UserId
+ creation UTCTime
+ amount Int
|]
type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
new file mode 100644
index 0000000..edf1c92
--- /dev/null
+++ b/src/server/Model/Income.hs
@@ -0,0 +1,21 @@
+module Model.Income
+ ( getIncome
+ , setIncome
+ ) where
+
+import Data.Time.Clock (getCurrentTime)
+
+import Control.Monad.IO.Class (liftIO)
+
+import Database.Persist
+
+import Model.Database
+
+getIncome :: UserId -> Persist (Maybe Income)
+getIncome userId =
+ fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation]
+
+setIncome :: UserId -> Int -> Persist IncomeId
+setIncome userId amount = do
+ now <- liftIO getCurrentTime
+ insert (Income userId now amount)