From 869bab77e93e2a6c776a4b1fc35ef0fd5df22f5f Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 27 Mar 2016 17:36:33 +0200
Subject: Compute payers client side rather than server side

---
 src/server/Controller/Income.hs  | 31 +++++++++++++++++++++++++++
 src/server/Controller/Payer.hs   | 20 -----------------
 src/server/Controller/User.hs    | 28 ------------------------
 src/server/Json.hs               | 10 +++++++++
 src/server/Main.hs               |  8 ++-----
 src/server/Model/Income.hs       | 14 ++++++------
 src/server/Model/Json/Income.hs  |  6 +++++-
 src/server/Model/Payer.hs        | 46 ----------------------------------------
 src/server/Model/Payer/Income.hs | 22 -------------------
 9 files changed, 56 insertions(+), 129 deletions(-)
 create mode 100644 src/server/Controller/Income.hs
 delete mode 100644 src/server/Controller/Payer.hs
 delete mode 100644 src/server/Model/Payer.hs
 delete mode 100644 src/server/Model/Payer/Income.hs

(limited to 'src/server')

diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs
new file mode 100644
index 0000000..51861d3
--- /dev/null
+++ b/src/server/Controller/Income.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Controller.Income
+  ( getIncomes
+  , setIncome
+  ) where
+
+import Web.Scotty
+
+import Control.Monad.IO.Class (liftIO)
+
+import Database.Persist
+
+import qualified Secure
+
+import Json (jsonId)
+
+import Model.Database
+import qualified Model.Income as Income
+
+getIncomes :: ActionM ()
+getIncomes =
+  Secure.loggedAction (\_ ->
+    (liftIO $ map Income.getJsonIncome <$> runDb Income.getIncomes) >>= json
+  )
+
+setIncome :: Int -> ActionM ()
+setIncome amount =
+  Secure.loggedAction (\user -> do
+    (liftIO . runDb $ Income.setIncome (entityKey user) amount) >>= jsonId
+  )
diff --git a/src/server/Controller/Payer.hs b/src/server/Controller/Payer.hs
deleted file mode 100644
index 70760ae..0000000
--- a/src/server/Controller/Payer.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Controller.Payer
-  ( getPayers
-  ) where
-
-import Web.Scotty
-
-import Control.Monad.IO.Class (liftIO)
-
-import Model.Database
-import qualified Model.Payer as P
-
-import Secure (loggedAction)
-
-getPayers :: ActionM ()
-getPayers =
-  Secure.loggedAction (\_ ->
-    (liftIO $ runDb P.getPayers) >>= json
-  )
diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs
index 420a2d9..1baab18 100644
--- a/src/server/Controller/User.hs
+++ b/src/server/Controller/User.hs
@@ -3,27 +3,16 @@
 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
 
-import Json (jsonObject)
-
 import Model.Database
 import qualified Model.User as U
-import qualified Model.Income as I
 
 getUsers :: ActionM ()
 getUsers =
@@ -36,20 +25,3 @@ whoAmI =
   Secure.loggedAction (\user ->
     json (U.getJsonUser user)
   )
-
-getIncome :: ActionM ()
-getIncome =
-  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/Json.hs b/src/server/Json.hs
index a2f1ef5..408742a 100644
--- a/src/server/Json.hs
+++ b/src/server/Json.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts           #-}
 
 module Json
   ( jsonObject
+  , jsonId
   ) where
 
 import Web.Scotty
@@ -10,5 +12,13 @@ import qualified Data.Aeson.Types as Json
 import qualified Data.HashMap.Strict as M
 import Data.Text (Text)
 
+import Database.Persist
+import Database.Persist.Sqlite
+
+import Model.Database
+
 jsonObject :: [(Text, Json.Value)] -> ActionM ()
 jsonObject = json . Json.Object . M.fromList
+
+jsonId :: (ToBackendKey SqlBackend a) => Key a -> ActionM ()
+jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral . keyToInt64 $ key)]
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 5688324..4f74f8e 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -15,7 +15,7 @@ import Controller.Index
 import Controller.SignIn
 import Controller.Payment
 import Controller.User
-import Controller.Payer
+import Controller.Income
 
 import Model.Database (runMigrations)
 import Model.Frequency
@@ -58,7 +58,7 @@ main = do
 
         get  "/users"  getUsers
         get  "/whoAmI" whoAmI
-        get  "/income" getIncome
+        get "/incomes" getIncomes
         post "/income" $ do
           amount <- param "amount" :: ActionM Int
           setIncome amount
@@ -80,7 +80,3 @@ main = do
           deletePayment paymentId
 
         get "/payments/count" getPaymentsCount
-
-        -- Payers
-
-        get "/payers" getPayers
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index 70b9149..2177617 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -1,5 +1,5 @@
 module Model.Income
-  ( getIncome
+  ( getJsonIncome
   , getFirstIncome
   , getIncomes
   , setIncome
@@ -12,13 +12,15 @@ import Control.Monad.IO.Class (liftIO)
 import Database.Persist
 
 import Model.Database
+import qualified Model.Json.Income as Json
 
-getIncome :: UserId -> Persist (Maybe Income)
-getIncome userId =
-  fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation]
+getJsonIncome :: Entity Income -> Json.Income
+getJsonIncome incomeEntity =
+  Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeCreation income) (incomeAmount income)
+  where income = entityVal incomeEntity
 
-getIncomes :: Persist [Income]
-getIncomes = map entityVal <$> selectList [] []
+getIncomes :: Persist [Entity Income]
+getIncomes = selectList [] []
 
 getFirstIncome :: UserId -> Persist (Maybe Income)
 getFirstIncome userId =
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
index 4549ca5..6ad331a 100644
--- a/src/server/Model/Json/Income.hs
+++ b/src/server/Model/Json/Income.hs
@@ -9,8 +9,12 @@ import GHC.Generics
 import Data.Aeson
 import Data.Time.Clock (UTCTime)
 
+import Model.Database (IncomeId, UserId)
+
 data Income = Income
-  { creation :: UTCTime
+  { id :: IncomeId
+  , userId :: UserId
+  , creation :: UTCTime
   , amount :: Int
   } deriving (Show, Generic)
 
diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs
deleted file mode 100644
index 3893765..0000000
--- a/src/server/Model/Payer.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module Model.Payer
-  ( getPayers
-  )
-  where
-
-import Control.Monad.IO.Class (liftIO)
-
-import Data.Time.Clock (getCurrentTime)
-import Data.List (find)
-import Data.Maybe (fromMaybe, fromMaybe)
-
-import Database.Persist
-
-import Model.Database
-import Model.Payer.Payment (getTotalPaymentsBefore, getTotalPaymentsAfter)
-import Model.Payer.Income (incomeDefinedForAll)
-import Model.User (getUsers)
-import Model.Income (getIncomes)
-
-import qualified Model.Json.Payer as Json
-import qualified Model.Json.Income as Json
-
-getPayers :: Persist [Json.Payer]
-getPayers = do
-  userIds <- map entityKey <$> getUsers
-  incomes <- getIncomes
-  now <- liftIO getCurrentTime
-  incomeIsDefined <- fromMaybe now <$> incomeDefinedForAll
-  preIncomePaymentSums <- getTotalPaymentsBefore incomeIsDefined
-  postIncomePaymentSums <- getTotalPaymentsAfter incomeIsDefined
-  return $ map (getPayer incomes preIncomePaymentSums postIncomePaymentSums) userIds
-
-getPayer :: [Income] -> [(UserId, Int)] -> [(UserId, Int)] -> UserId -> Json.Payer
-getPayer incomes preIncomePaymentSums postIncomePaymentSums userId =
-  Json.Payer
-    { Json.userId = userId
-    , Json.preIncomePaymentSum = findOrDefault userId 0 preIncomePaymentSums
-    , Json.postIncomePaymentSum = findOrDefault userId 0 postIncomePaymentSums
-    , Json.incomes =
-        map (\income -> Json.Income (incomeCreation income) (incomeAmount income))
-        . filter ((==) userId . incomeUserId)
-        $ incomes
-    }
-
-findOrDefault :: (Eq a) => a -> b -> [(a, b)] -> b
-findOrDefault a b = fromMaybe b . fmap snd . find ((==) a . fst)
diff --git a/src/server/Model/Payer/Income.hs b/src/server/Model/Payer/Income.hs
deleted file mode 100644
index f4bc9fd..0000000
--- a/src/server/Model/Payer/Income.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Model.Payer.Income
-  ( incomeDefinedForAll
-  ) where
-
-import Data.Time.Clock (UTCTime)
-import Data.List (sort)
-import Data.Maybe
-
-import Database.Persist
-
-import Model.Database
-import Model.User (getUsers)
-import Model.Income (getFirstIncome)
-
-incomeDefinedForAll :: Persist (Maybe UTCTime)
-incomeDefinedForAll = do
-  userIds <- map entityKey <$> getUsers
-  firstIncomes <- mapM getFirstIncome userIds
-  return $
-    if all isJust firstIncomes
-      then listToMaybe . reverse . sort . map incomeCreation . catMaybes $ firstIncomes
-      else Nothing
-- 
cgit v1.2.3