From 5babf01323bcb62a9880593165af70732f22751b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Sep 2015 12:04:52 +0200
Subject: Adding income database table with a getter and a setter

---
 database-shm                    | Bin 0 -> 32768 bytes
 database-wal                    | Bin 0 -> 6320 bytes
 src/server/Controller/SignIn.hs |  16 ++++++++--------
 src/server/Controller/User.hs   |  25 +++++++++++++++++++++----
 src/server/Main.hs              |   9 ++++++---
 src/server/Model/Database.hs    |   4 ++++
 src/server/Model/Income.hs      |  21 +++++++++++++++++++++
 7 files changed, 60 insertions(+), 15 deletions(-)
 create mode 100644 database-shm
 create mode 100644 database-wal
 create mode 100644 src/server/Model/Income.hs

diff --git a/database-shm b/database-shm
new file mode 100644
index 0000000..494f47a
Binary files /dev/null and b/database-shm differ
diff --git a/database-wal b/database-wal
new file mode 100644
index 0000000..4d24ee6
Binary files /dev/null and b/database-wal differ
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)
-- 
cgit v1.2.3