From 6b466f616035c2fc03359d182c074f096d6b7f17 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 29 Aug 2015 13:30:09 +0200
Subject: Showing exceeding payers

---
 src/client/Main.elm                         |  6 ++-
 src/client/Model/Payers.elm                 | 57 +++++++++++++++++++++++++++++
 src/client/Model/View/PaymentView.elm       |  7 +++-
 src/client/Update.elm                       |  7 ++--
 src/client/Update/Payment.elm               | 12 +++++-
 src/client/View/Payments.elm                |  4 +-
 src/client/View/Payments/ExceedingPayer.elm | 24 ++++++++++++
 src/server/Config.hs                        |  6 ++-
 src/server/Controller/Payment.hs            |  7 ++++
 src/server/Controller/SignIn.hs             |  6 +--
 src/server/Design/Color.hs                  |  2 +-
 src/server/Design/Global.hs                 | 14 +++++--
 src/server/Main.hs                          |  5 ++-
 src/server/Model/Database.hs                |  2 +-
 src/server/Model/Json/TotalPayment.hs       | 18 +++++++++
 src/server/Model/Payment.hs                 | 20 ++++++++++
 16 files changed, 178 insertions(+), 19 deletions(-)
 create mode 100644 src/client/Model/Payers.elm
 create mode 100644 src/client/View/Payments/ExceedingPayer.elm
 create mode 100644 src/server/Model/Json/TotalPayment.hs

(limited to 'src')

diff --git a/src/client/Main.elm b/src/client/Main.elm
index badb450..57e41d4 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -13,6 +13,7 @@ import Json.Decode as Json
 
 import Model exposing (Model, initialModel)
 import Model.Payment exposing (Payments, paymentsDecoder)
+import Model.Payers exposing (Payers, payersDecoder)
 import Model.Message exposing (messageDecoder)
 import Model.Translations exposing (..)
 
@@ -55,7 +56,7 @@ port initView =
     Just msg ->
       Signal.send actions.address (SignInError msg)
     Nothing ->
-      Task.map2 GoPaymentView getUserName getPayments
+      Task.map3 GoPaymentView getUserName getPayments getPayers
         |> flip Task.andThen (Signal.send actions.address)
         |> flip Task.onError (\_ -> Signal.send actions.address GoSignInView)
 
@@ -65,6 +66,9 @@ getUserName = Http.get messageDecoder "/userName"
 getPayments : Task Http.Error Payments
 getPayments = Http.get paymentsDecoder "/payments"
 
+getPayers : Task Http.Error Payers
+getPayers = Http.get payersDecoder "/payments/total"
+
 ---------------------------------------
 
 port serverCommunicationsPort : Signal (Task Http.RawError ())
diff --git a/src/client/Model/Payers.elm b/src/client/Model/Payers.elm
new file mode 100644
index 0000000..6550eaa
--- /dev/null
+++ b/src/client/Model/Payers.elm
@@ -0,0 +1,57 @@
+module Model.Payers
+  ( Payers
+  , ExceedingPayer
+  , payersDecoder
+  , updatePayers
+  , getOrderedExceedingPayers
+  ) where
+
+import Json.Decode as Json exposing (..)
+import Dict exposing (..)
+import List
+import Maybe
+
+type alias Payers = Dict String Int
+
+payersDecoder : Decoder Payers
+payersDecoder = Json.map Dict.fromList (list payerDecoder)
+
+payerDecoder : Decoder (String, Int)
+payerDecoder =
+  object2 (,)
+    ("userName" := string)
+    ("totalPayment" := int)
+
+updatePayers : Payers -> String -> Int -> Payers
+updatePayers payers userName amountDiff =
+  Dict.update
+    userName
+    (\mbAmount ->
+      case mbAmount of
+        Just amount -> Just (amount + amountDiff)
+        Nothing -> Nothing
+    )
+    payers
+
+type alias ExceedingPayer =
+  { userName : String
+  , amount : Int
+  }
+
+getOrderedExceedingPayers : Payers -> List ExceedingPayer
+getOrderedExceedingPayers payers =
+  let orderedPayers =
+        Dict.toList payers
+          |> List.map (\(userName, amount) -> ExceedingPayer userName amount)
+          |> List.sortBy .amount
+      maybeMinAmount =
+        List.head orderedPayers
+          |> Maybe.map .amount
+  in  case maybeMinAmount of
+        Just minAmount ->
+          orderedPayers
+            |> List.map (\payer -> { payer | amount <- payer.amount - minAmount })
+            |> List.filter (\payer -> payer.amount /= 0)
+            |> List.reverse
+        Nothing ->
+          []
diff --git a/src/client/Model/View/PaymentView.elm b/src/client/Model/View/PaymentView.elm
index 2f2be46..19ad355 100644
--- a/src/client/Model/View/PaymentView.elm
+++ b/src/client/Model/View/PaymentView.elm
@@ -4,6 +4,7 @@ module Model.View.PaymentView
   ) where
 
 import Model.Payment exposing (Payments)
+import Model.Payers exposing (Payers)
 import Model.View.Payment.Add exposing (..)
 import Model.View.Payment.Edition exposing (..)
 
@@ -11,13 +12,15 @@ type alias PaymentView =
   { userName : String
   , add : AddPayment
   , payments : Payments
+  , payers : Payers
   , edition : Maybe Edition
   }
 
-initPaymentView : String -> Payments -> PaymentView
-initPaymentView userName payments =
+initPaymentView : String -> Payments -> Payers -> PaymentView
+initPaymentView userName payments payers =
   { userName = userName
   , add = initAddPayment
   , payments = payments
+  , payers = payers
   , edition = Nothing
   }
diff --git a/src/client/Update.elm b/src/client/Update.elm
index be7538a..df19775 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -8,6 +8,7 @@ import Time exposing (Time)
 
 import Model exposing (Model)
 import Model.Payment exposing (Payments)
+import Model.Payers exposing (Payers)
 import Model.View as V
 import Model.View.SignInView exposing (..)
 import Model.View.PaymentView exposing (..)
@@ -21,7 +22,7 @@ type Action =
   | GoSignInView
   | SignInError String
   | UpdateSignIn SignInAction
-  | GoPaymentView String Payments
+  | GoPaymentView String Payments Payers
   | UpdatePayment PaymentAction
 
 actions : Signal.Mailbox Action
@@ -36,8 +37,8 @@ updateModel action model =
       { model | currentTime <- time }
     GoSignInView ->
       { model | view <- V.SignInView initSignInView }
-    GoPaymentView userName payments ->
-      { model | view <- V.PaymentView (initPaymentView userName payments) }
+    GoPaymentView userName payments payers ->
+      { model | view <- V.PaymentView (initPaymentView userName payments payers) }
     SignInError msg ->
       let signInView = { initSignInView | result <- Just (Err msg) }
       in  { model | view <- V.SignInView signInView }
diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm
index 67331d6..53dc08a 100644
--- a/src/client/Update/Payment.elm
+++ b/src/client/Update/Payment.elm
@@ -4,9 +4,11 @@ module Update.Payment
   ) where
 
 import Date
+import Dict
 
 import Model exposing (Model)
 import Model.Payment exposing (..)
+import Model.Payers exposing (..)
 import Model.View.PaymentView exposing (..)
 import Model.View.Payment.Add exposing (..)
 
@@ -36,8 +38,16 @@ updatePayment model action paymentView =
       in  { paymentView
           | payments <- addPayment paymentView.payments (id, payment)
           , add <- initAddPayment
+          , payers <- updatePayers paymentView.payers payment.userName payment.cost
           }
     ToggleEdit id ->
       { paymentView | edition <- if paymentView.edition == Just id then Nothing else Just id }
     Remove id ->
-      { paymentView | payments <- removePayment paymentView.payments id }
+      case Dict.get id paymentView.payments of
+        Just payment ->
+          { paymentView
+          | payments <- removePayment paymentView.payments id
+          , payers <- updatePayers paymentView.payers payment.userName -payment.cost
+          }
+        Nothing ->
+          paymentView
diff --git a/src/client/View/Payments.elm b/src/client/View/Payments.elm
index 29ab481..03886f8 100644
--- a/src/client/View/Payments.elm
+++ b/src/client/View/Payments.elm
@@ -9,6 +9,7 @@ import Model exposing (Model)
 import Model.Payment exposing (Payments)
 import Model.View.PaymentView exposing (PaymentView)
 
+import View.Payments.ExceedingPayer exposing (exceedingPayers)
 import View.Payments.Add exposing (addPayment)
 import View.Payments.Table exposing (paymentsTable)
 
@@ -16,6 +17,7 @@ renderPayments : Model -> PaymentView -> Html
 renderPayments model paymentView =
   div
     [ class "payments" ]
-    [ addPayment model paymentView.add
+    [ exceedingPayers paymentView
+    , addPayment model paymentView.add
     , paymentsTable model paymentView
     ]
diff --git a/src/client/View/Payments/ExceedingPayer.elm b/src/client/View/Payments/ExceedingPayer.elm
new file mode 100644
index 0000000..cea8d66
--- /dev/null
+++ b/src/client/View/Payments/ExceedingPayer.elm
@@ -0,0 +1,24 @@
+module View.Payments.ExceedingPayer
+  ( exceedingPayers
+  ) where
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import List
+
+import Model.Payers exposing (..)
+import Model.View.PaymentView exposing (PaymentView)
+
+exceedingPayers : PaymentView -> Html
+exceedingPayers paymentView =
+  div
+    [ class "exceedingPayers" ]
+    (List.map exceedingPayer (getOrderedExceedingPayers paymentView.payers))
+
+exceedingPayer : ExceedingPayer -> Html
+exceedingPayer payer =
+  div
+    [ class "exceedingPayer" ]
+    [ span [ class "userName" ] [ text payer.userName ]
+    , span [ class "amount" ] [ text ("+ " ++ (toString payer.amount)) ]
+    ]
diff --git a/src/server/Config.hs b/src/server/Config.hs
index 9bc780f..895b355 100644
--- a/src/server/Config.hs
+++ b/src/server/Config.hs
@@ -14,19 +14,21 @@ import Control.Monad.Trans.Error (runErrorT)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (join)
 import Control.Arrow (left)
-import Control.Applicative (liftA2)
+import Control.Applicative (liftA3)
 
 data Config = Config
   { hostname :: Text
   , port :: Int
+  , signInExpirationMn :: Int
   } deriving (Read, Eq, Show)
 
 getConfig :: FilePath -> IO (Either Text Config)
 getConfig filePath =
   left (T.pack . show) <$> (runErrorT $ do
     cp <- join $ liftIO $ readfile emptyCP filePath
-    liftA2
+    liftA3
       Config
       (T.pack <$> get cp "DEFAULT" "hostname")
       (get cp "DEFAULT" "port")
+      (get cp "DEFAULT" "sign-in-expiration-mn")
   )
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index cbd342a..117310a 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -2,6 +2,7 @@ module Controller.Payment
   ( getPaymentsAction
   , createPaymentAction
   , deletePaymentAction
+  , getTotalPaymentsAction
   ) where
 
 import Web.Scotty
@@ -47,3 +48,9 @@ deletePaymentAction paymentId =
         status badRequest400
         json . Message . getMessage $ PaymentNotDeleted
   )
+
+getTotalPaymentsAction :: ActionM ()
+getTotalPaymentsAction =
+  Secure.loggedAction (\_ -> do
+    (liftIO . runDb $ getTotalPayments) >>= json
+  )
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 80885bf..40cf474 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -61,8 +61,8 @@ errorResponse msg = do
   status badRequest400
   json (Message msg)
 
-validateSignInAction :: Text -> ActionM ()
-validateSignInAction token = do
+validateSignInAction :: Config -> Text -> ActionM ()
+validateSignInAction config token = do
   maybeSignIn <- liftIO . runDb $ getSignInToken token
   now <- liftIO getCurrentTime
   case maybeSignIn of
@@ -72,7 +72,7 @@ validateSignInAction token = do
           redirectError (getMessage SignInUsed)
         else
           let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
-          in  if diffTime > 2 * 60 -- 2 minutes
+          in  if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
                 then
                   redirectError (getMessage SignInExpired)
                 else do
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index f4223a2..f5bd59d 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -15,7 +15,7 @@ orange :: C.Color
 orange = C.orange
 
 green :: C.Color
-green = C.green
+green = C.rgb 165 213 42
 
 darkgrey :: C.Color
 darkgrey = C.rgb 150 150 150
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index f7dd28d..f61fa66 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -4,9 +4,6 @@ module Design.Global
   ( globalDesign
   ) where
 
-import qualified Prelude
-import Prelude
-
 import Data.Monoid ((<>))
 
 import Clay
@@ -51,6 +48,17 @@ global = do
       hover & transform (scale 1.2 1.2)
 
   ".payments" ? do
+
+    ".exceedingPayers" ? do
+      margin (px 0) (px 20) (px 45) (px 20)
+      padding (px 10) (px 10) (px 10) (px 10)
+      backgroundColor C.green
+      color C.white
+      fontWeight bold
+      borderRadius (px 5) (px 5) (px 5) (px 5)
+
+      ".exceedingPayer" Clay.** ".userName" ? marginRight (px 10)
+
     form # ".add" ? do
       let inputHeight = 40
       width (pct 80)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 1363f33..61613e6 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -37,7 +37,7 @@ main = do
 
         get "/validateSignIn" $ do
           token <- param "token" :: ActionM Text
-          validateSignInAction token
+          validateSignInAction config token
 
         get "/userName" $
           getUserName
@@ -54,6 +54,9 @@ main = do
           paymentId <- param "id" :: ActionM Text
           deletePaymentAction paymentId
 
+        get "/payments/total" $ do
+          getTotalPaymentsAction
+
         post "/signOut" $
           signOutAction
 
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 8715ca1..a6ce4f4 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -26,7 +26,7 @@ User
   creation UTCTime
   email Text
   name Text
-  EmailKey email
+  UniqEmail email
   UniqName name
   deriving Show
 Payment
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
new file mode 100644
index 0000000..e386c79
--- /dev/null
+++ b/src/server/Model/Json/TotalPayment.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.TotalPayment
+  ( TotalPayment(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Text (Text)
+import Data.Aeson
+
+data TotalPayment = TotalPayment
+  { userName :: Text
+  , totalPayment :: Int
+  } deriving (Show, Generic)
+
+instance FromJSON TotalPayment
+instance ToJSON TotalPayment
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 51f09b9..300f6b8 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -3,11 +3,13 @@ module Model.Payment
   , createPayment
   , paymentKeyToText
   , deleteOwnPayment
+  , getTotalPayments
   ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
+import Data.Maybe (catMaybes)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -18,6 +20,7 @@ import qualified Database.Esqueleto as E
 
 import Model.Database
 import qualified Model.Json.Payment as P
+import qualified Model.Json.TotalPayment as TP
 
 getPayments :: Persist [P.Payment]
 getPayments = do
@@ -62,3 +65,20 @@ deleteOwnPayment user paymentId = do
           return False
     Nothing ->
       return False
+
+getTotalPayments :: Persist [TP.TotalPayment]
+getTotalPayments = do
+  values <- select $
+            from $ \(payment `InnerJoin` user) -> do
+              on (payment ^. PaymentUserId E.==. user ^. UserId)
+              where_ (isNothing (payment ^. PaymentDeletedAt))
+              groupBy (payment ^. PaymentUserId)
+              return (user ^. UserName, sum_ (payment ^. PaymentCost))
+  return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
+
+getTotalPayment :: (Text, Maybe Int) -> Maybe TP.TotalPayment
+getTotalPayment (userName, Just cost) = Just (TP.TotalPayment userName cost)
+getTotalPayment (_, Nothing) = Nothing
+
+unValueTuple :: (Value a, Value b) -> (a, b)
+unValueTuple (Value a, Value b) = (a, b)
-- 
cgit v1.2.3