Showing exceeding payers

9 files changed, 69 insertions, 11 deletions

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)