aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--config.txt1
-rw-r--r--src/client/Main.elm6
-rw-r--r--src/client/Model/Payers.elm57
-rw-r--r--src/client/Model/View/PaymentView.elm7
-rw-r--r--src/client/Update.elm7
-rw-r--r--src/client/Update/Payment.elm12
-rw-r--r--src/client/View/Payments.elm4
-rw-r--r--src/client/View/Payments/ExceedingPayer.elm24
-rw-r--r--src/server/Config.hs6
-rw-r--r--src/server/Controller/Payment.hs7
-rw-r--r--src/server/Controller/SignIn.hs6
-rw-r--r--src/server/Design/Color.hs2
-rw-r--r--src/server/Design/Global.hs14
-rw-r--r--src/server/Main.hs5
-rw-r--r--src/server/Model/Database.hs2
-rw-r--r--src/server/Model/Json/TotalPayment.hs18
-rw-r--r--src/server/Model/Payment.hs20
17 files changed, 179 insertions, 19 deletions
diff --git a/config.txt b/config.txt
index ddf4a18..efbd709 100644
--- a/config.txt
+++ b/config.txt
@@ -1,2 +1,3 @@
hostname = localhost:3001
port = 3001
+sign-in-expiration-mn = 5
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-06 11:31:07 +0000