aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-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
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:51:36 +0000