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/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 ++++++++++++++++++++ 9 files changed, 69 insertions(+), 11 deletions(-) create mode 100644 src/server/Model/Json/TotalPayment.hs (limited to 'src/server') 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