diff options
Diffstat (limited to 'server/src')
72 files changed, 3666 insertions, 0 deletions
diff --git a/server/src/Conf.hs b/server/src/Conf.hs new file mode 100644 index 0000000..ca19c8d --- /dev/null +++ b/server/src/Conf.hs @@ -0,0 +1,39 @@ +module Conf + ( get + , Conf(..) + ) where + +import qualified Data.ConfigManager as Conf +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) + +import Common.Model (Currency (..)) + +data Conf = Conf + { hostname :: Text + , port :: Int + , signInExpiration :: NominalDiffTime + , currency :: Currency + , noReplyMail :: Text + , https :: Bool + , devMode :: Bool + } deriving Show + +get :: FilePath -> IO Conf +get path = do + conf <- + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "hostname" conf <*> + Conf.lookup "port" conf <*> + Conf.lookup "signInExpiration" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> + Conf.lookup "noReplyMail" conf <*> + Conf.lookup "https" conf <*> + Conf.lookup "devMode" conf + ) + case conf of + Left msg -> error (T.unpack msg) + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..371ba78 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,88 @@ +module Controller.Category + ( listAll + , list + , create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) + +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Validation.Category as CategoryValidation + +listAll :: ActionM () +listAll = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json + ) + +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + usedCategories <- PaymentPersistence.usedCategories + count <- CategoryPersistence.count + return $ CategoryPage page categories usedCategories count + ) >>= json + ) + +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + CategoryPersistence.delete categoryId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted + ) diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs new file mode 100644 index 0000000..dc9cbc4 --- /dev/null +++ b/server/src/Controller/Helper.hs @@ -0,0 +1,16 @@ +module Controller.Helper + ( okOrBadRequest + ) where + +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do + S.status Status.badRequest400 + S.text (LT.fromStrict message) +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..96ccbbc --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,90 @@ +module Controller.Income + ( list + , create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (..)) +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty hiding (delete) + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..), + IncomeHeader (..), IncomeId, + IncomePage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure +import qualified Validation.Income as IncomeValidation + +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime + (liftIO . Query.run $ do + count <- IncomePersistence.count + + users <- UserPersistence.list + let userIds = _user_id <$> users + + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll + + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty + + incomes <- IncomePersistence.list page perPage + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json + ) + +create :: CreateIncomeForm -> ActionM () +create form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.createIncome form of + Success (CreateIncome amount date) -> do + Right <$> (IncomePersistence.create (_user_id user) date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditIncomeForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.editIncome form of + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: IncomeId -> ActionM () +delete incomeId = + Secure.loggedAction (\user -> do + _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId + status Status.ok200 + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..4f4ae77 --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,76 @@ +module Controller.Index + ( get + , signIn + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) +import qualified Network.HTTP.Types.Status as Status +import Prelude hiding (error, init) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import Common.Model (Init (..), SignInForm (..), + User (..)) +import qualified Common.Msg as Msg + +import Conf (Conf (..)) +import qualified LoginSession +import Model.Query (Query) +import qualified Model.Query as Query +import Model.SignIn (SignIn (..)) +import qualified Persistence.User as UserPersistence +import qualified Validation.SignIn as SignInValidation +import View.Page (page) + +get :: Conf -> ActionM () +get conf = do + init <- do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init + +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = + case SignInValidation.signIn form of + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init + + Nothing -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) + Nothing -> + return Nothing + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..d6aa34f --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,116 @@ +module Controller.Payment + ( list + , create + , edit + , delete + , searchCategory + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) +import qualified Model.Query as Query +import qualified Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure +import qualified Validation.Payment as PaymentValidation + +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search + + users <- UserPersistence.list + + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty + + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition + + header = PaymentHeader + { _paymentHeader_exceedingPayers = exceedingPayers + , _paymentHeader_repartition = searchRepartition + } + + return $ PaymentPage page frequency header payments count) >>= S.json + ) + +create :: CreatePaymentForm -> ActionM () +create form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.listAll + case PaymentValidation.createPayment cs form of + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditPaymentForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.listAll + case PaymentValidation.editPayment cs form of + Success (EditPayment paymentId name cost date category frequency) -> do + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_PaymentEdit + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: PaymentId -> ActionM () +delete paymentId = + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json + ) diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs new file mode 100644 index 0000000..500c93c --- /dev/null +++ b/server/src/Controller/Statistics.hs @@ -0,0 +1,21 @@ +module Controller.Statistics + ( paymentsAndIncomes + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Statistics + +paymentsAndIncomes :: ActionM () +paymentsAndIncomes = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + incomes <- liftIO $ Query.run IncomePersistence.listAll + S.json (Statistics.paymentsAndIncomes payments incomes) + ) diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs new file mode 100644 index 0000000..a7bb136 --- /dev/null +++ b/server/src/Controller/User.hs @@ -0,0 +1,17 @@ +module Controller.User + ( list + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ UserPersistence.list) >>= S.json + ) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs new file mode 100644 index 0000000..f79a1fa --- /dev/null +++ b/server/src/Cookie.hs @@ -0,0 +1,54 @@ +module Cookie + ( makeSimpleCookie + , setCookie + , setSimpleCookie + , getCookie + , getCookies + , deleteCookie + ) where + +import Control.Monad (liftM) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL + +import Conf (Conf) +import qualified Conf + +import qualified Data.Map as Map + +import qualified Data.ByteString.Lazy as BSL + +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +import Blaze.ByteString.Builder (toLazyByteString) + +import Web.Cookie +import Web.Scotty.Trans + +makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie +makeSimpleCookie conf name value = + def + { setCookieName = TS.encodeUtf8 name + , setCookieValue = TS.encodeUtf8 value + , setCookiePath = Just $ TS.encodeUtf8 "/" + , setCookieSecure = Conf.https conf + } + +setCookie :: (Monad m) => SetCookie -> ActionT e m () +setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) + +setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () +setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value + +getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) +getCookie name = liftM (Map.lookup name) getCookies + +getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) +getCookies = + liftM (Map.fromList . maybe [] parse) $ header "Cookie" + where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + +deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () +deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/server/src/Design/Appearing.hs b/server/src/Design/Appearing.hs new file mode 100644 index 0000000..79b94b3 --- /dev/null +++ b/server/src/Design/Appearing.hs @@ -0,0 +1,25 @@ +module Design.Appearing + ( design + ) where + +import Clay + +design :: Css +design = do + + appearKeyframe + + ".g-Appearing" ? do + appearAnimation + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs new file mode 100644 index 0000000..e7f5aec --- /dev/null +++ b/server/src/Design/Color.hs @@ -0,0 +1,40 @@ +module Design.Color where + +import Clay +import qualified Clay.Color as C +import Data.Text (Text) + +-- http://chir.ag/projects/name-that-color/#969696 + +white :: C.Color +white = C.white + +black :: C.Color +black = C.black + +chestnutRose :: C.Color +chestnutRose = C.rgb 207 92 86 + +unknown :: C.Color +unknown = C.rgb 86 92 207 + +mossGreen :: C.Color +mossGreen = C.rgb 159 210 165 + +gothic :: C.Color +gothic = C.rgb 108 162 164 + +negroni :: C.Color +negroni = C.rgb 255 223 196 + +wildSand :: C.Color +wildSand = C.rgb 245 245 245 + +silver :: C.Color +silver = C.rgb 200 200 200 + +dustyGray :: C.Color +dustyGray = C.rgb 150 150 150 + +toString :: C.Color -> Text +toString = plain . unValue . value diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs new file mode 100644 index 0000000..a3123d9 --- /dev/null +++ b/server/src/Design/Constants.hs @@ -0,0 +1,27 @@ +module Design.Constants where + +import Clay + +iconFontSize :: Size LengthUnit +iconFontSize = px 32 + +radius :: Size LengthUnit +radius = px 3 + +blockPadding :: Size LengthUnit +blockPadding = px 15 + +blockPercentWidth :: Double +blockPercentWidth = 90 + +blockPercentMargin :: Double +blockPercentMargin = (100 - blockPercentWidth) / 2 + +inputHeight :: Double +inputHeight = 40 + +focusLighten :: Color -> Color +focusLighten baseColor = baseColor +. 20 + +focusDarken :: Color -> Color +focusDarken baseColor = baseColor -. 20 diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs new file mode 100644 index 0000000..9f435eb --- /dev/null +++ b/server/src/Design/Errors.hs @@ -0,0 +1,53 @@ +module Design.Errors + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + position fixed + top (px 20) + left (pct 50) + "transform" -: "translateX(-50%)" + margin (px 0) (px 0) (px 0) (px 0) + disapearKeyframes + + ".error" ? do + disapearAnimation + let errorColor = Color.chestnutRose -. 15 + color errorColor + border solid (px 2) errorColor + backgroundColor Color.white + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + + before & display none + +disapearAnimation :: Css +disapearAnimation = do + animationName "disapear" + animationDelay (sec 5) + animationDuration (sec 1) + animationFillMode forwards + +disapearKeyframes :: Css +disapearKeyframes = keyframes + "disapear" + [ ( 10 + , do + opacity 0 + height (px 40) + lineHeight (px 40) + marginBottom (px 10) + ) + , ( 100 + , do + opacity 0 + height (px 0) + lineHeight (px 0) + marginBottom (px 0) + ) + ] diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs new file mode 100644 index 0000000..5713bfe --- /dev/null +++ b/server/src/Design/Form.hs @@ -0,0 +1,101 @@ +module Design.Form + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color + +design :: Css +design = do + + let inputHeight = 30 + let inputTop = 22 + let inputPaddingBottom = 3 + + ".textInput" ? do + position relative + marginBottom (em 2) + paddingTop (px inputTop) + marginTop (px (-10)) + + input ? do + width (pct 100) + position relative + backgroundColor transparent + paddingBottom (px inputPaddingBottom) + paddingRight (px 14) -- Space for the delete icon + borderStyle none + borderBottom solid (px 1) Color.dustyGray + marginBottom (px 5) + height (px inputHeight) + lineHeight (px inputHeight) + focus & do + borderWidth (px 2) + paddingBottom (px $ inputPaddingBottom - 1) + + ".label" ? do + zIndex (-1) + color Color.silver + lineHeight (px inputHeight) + position absolute + top (px inputTop) + left (px 0) + transition "all" (sec 0.2) easeInOut (sec 0) + + button ? do + position absolute + right (px 0) + top (px 27) + svg ? "path" ? + ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? + ("fill" -: Color.toString (Color.silver -. 25)) + + (input # ".filled" |+ ".label") <> (input # focus |+ ".label") ? do + top (px 0) + fontSize (pct 80) + + ".error" & do + input ? do + borderBottomColor Color.chestnutRose + + ".errorMessage" ? do + position absolute + color Color.chestnutRose + fontSize (pct 80) + + ".colorInput" ? do + display flex + alignItems center + marginBottom (em 1.5) + + input ? do + borderColor transparent + backgroundColor transparent + + ".selectInput" ? do + + ".label" ? do + color Color.silver + display block + marginBottom (px 10) + fontSize (pct 80) + + select ? do + width (pct 100) + backgroundColor Color.white + border solid (px 1) Color.silver + sym borderRadius (px 3) + sym2 padding (px 5) (px 8) + option ? sym2 padding (px 5) (px 8) + focus & backgroundColor Color.wildSand + + ".error" & do + select ? borderColor Color.chestnutRose + ".errorMessage" ? do + color Color.chestnutRose + fontSize (pct 80) + marginTop (em 0.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs new file mode 100644 index 0000000..c67db7c --- /dev/null +++ b/server/src/Design/Global.hs @@ -0,0 +1,165 @@ +module Design.Global + ( globalDesign + ) where + +import Clay +import Clay.Color as C +import Data.Text.Lazy (Text) + +import qualified Design.Appearing as Appearing +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Errors as Errors +import qualified Design.Form as Form +import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable +import qualified Design.Media as Media +import qualified Design.Modal as Modal +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views + +globalDesign :: Text +globalDesign = renderWith compact [] global + +global :: Css +global = do + ".errors" ? Errors.design + Appearing.design + Modal.design + ".tooltip" ? Tooltip.design + Views.design + Form.design + Loadable.design + + spinKeyframes + appearKeyframe + + html ? do + height (pct 100) + + "g-Body--Modal" ? + overflowY hidden + + body ? do + position relative + minWidth (px 320) + height (pct 100) + fontFamily ["Cantarell"] [sansSerif] + Media.tablet $ do + fontSize (px 15) + button ? fontSize (px 15) + input ? fontSize (px 15) + Media.mobile $ do + fontSize (px 14) + button ? fontSize (px 14) + input ? fontSize (px 14) + + ".app" ? do + appearAnimation + display flex + height (pct 100) + flexDirection column + + -- "main" ? + -- appearAnimation + + ".pageSpinner" ? do + display flex + alignItems center + justifyContent center + flexGrow 1 + + ".spinner" ? do + display flex + alignItems center + justifyContent center + width (pct 100) + height (pct 100) + paddingBottom (pct 10) + + before & do + display block + content (stringContent "") + width (px 50) + height (px 50) + border solid (px 3) (C.setA 0.3 Color.chestnutRose) + sym borderRadius (pct 50) + borderTopColor Color.chestnutRose + spinKeyframes + spinAnimation + + a ? cursor pointer + + input ? fontSize inherit + + h1 ? do + color Color.chestnutRose + lineHeight (em 1.3) + + Media.desktop $ fontSize (px 24) + Media.tablet $ fontSize (px 22) + Media.mobile $ fontSize (px 20) + + ul ? do + "margin-top" -: "1vh" + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li <? do + "margin-bottom" -: "2vh" + before & do + content (stringContent "• ") + color Color.chestnutRose + "margin-right" -: "0.3vw" + ul <? do + "margin-left" -: "3vh" + "margin-top" -: "2vh" + + ".dialog" ? ".content" ? button ? do + ".confirm" & Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + svg ? height (pct 100) + + button ? do + position relative + + ".content" ? do + display flex + + svg # ".loader" ? do + display none + position absolute + + ".waiting" & do + ".content" ? do + opacity 0 + svg # ".loader" ? do + display block + spinAnimation + + select ? cursor pointer + +spinAnimation :: Css +spinAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeInOut + animationIterationCount infinite + +spinKeyframes :: Css +spinKeyframes = keyframes + "rotate" + [ (100, "transform" -: "rotate(360deg)") + ] + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs new file mode 100644 index 0000000..e586d56 --- /dev/null +++ b/server/src/Design/Helper.hs @@ -0,0 +1,48 @@ +module Design.Helper + ( clearFix + , button + , centeredWithMargin + , verticalCentering + ) where + +import Prelude hiding (span) + +import Clay hiding (button) + +import Design.Constants + +clearFix :: Css +clearFix = + after & do + content (stringContent "") + display displayTable + clear both + +button :: Color -> Color -> Size a -> (Color -> Color) -> Css +button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center + backgroundColor backgroundCol + padding (px 0) (px 10) (px 0) (px 10) + color textCol + borderRadius radius radius radius radius + verticalAlign middle + cursor pointer + lineHeight h + height h + textAlign (alignSide sideCenter) + hover & backgroundColor (focusOp backgroundCol) + focus & backgroundColor (focusOp backgroundCol) + +centeredWithMargin :: Css +centeredWithMargin = do + width (pct blockPercentWidth) + marginLeft auto + marginRight auto + +verticalCentering :: Css +verticalCentering = do + position absolute + top (pct 50) + "transform" -: "translateY(-50%)" diff --git a/server/src/Design/Loadable.hs b/server/src/Design/Loadable.hs new file mode 100644 index 0000000..6b13f2d --- /dev/null +++ b/server/src/Design/Loadable.hs @@ -0,0 +1,29 @@ +module Design.Loadable + ( design + ) where + +import Clay + +design :: Css +design = do + ".g-Loadable" ? do + position relative + width (pct 100) + height (pct 100) + + ".g-Loadable__Spinner" ? do + position absolute + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + display none + + ".g-Loadable__Spinner--Loading" ? do + display block + + ".g-Loadable__Content" ? + transition "opacity" (sec 0.4) ease (sec 0) + + ".g-Loadable__Content--Loading" ? + opacity 0.5 diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs new file mode 100644 index 0000000..19a3b8c --- /dev/null +++ b/server/src/Design/Media.hs @@ -0,0 +1,36 @@ +module Design.Media + ( mobile + , mobileTablet + , tablet + , tabletDesktop + , desktop + ) where + +import Clay hiding (query) +import qualified Clay +import qualified Clay.Media as Media +import Clay.Stylesheet (Feature) + +mobile :: Css -> Css +mobile = query [Media.maxWidth mobileTabletLimit] + +mobileTablet :: Css -> Css +mobileTablet = query [Media.maxWidth tabletDesktopLimit] + +tablet :: Css -> Css +tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] + +tabletDesktop :: Css -> Css +tabletDesktop = query [Media.minWidth mobileTabletLimit] + +desktop :: Css -> Css +desktop = query [Media.minWidth tabletDesktopLimit] + +query :: [Feature] -> Css -> Css +query = Clay.query Media.screen + +mobileTabletLimit :: Size LengthUnit +mobileTabletLimit = (px 520) + +tabletDesktopLimit :: Size LengthUnit +tabletDesktopLimit = (px 950) diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs new file mode 100644 index 0000000..1195e10 --- /dev/null +++ b/server/src/Design/Modal.hs @@ -0,0 +1,69 @@ +module Design.Modal + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.View.Payment.Form as Form + +design :: Css +design = do + + appearKeyframe + + ".g-Modal" ? do + display none + appearAnimation + transition "all" (sec 0.2) ease (sec 0) + opacity 0 + + ".g-Modal--Show" & do + display block + opacity 1 + + ".g-Modal--Hiding" & do + display block + + ".g-Modal__Curtain" ? do + position fixed + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + backgroundColor (rgba 0 0 0 0.6) + zIndex 1 + + ".g-Modal__Content" ? do + minWidth (px 300) + position fixed + top (pct 25) + left (pct 50) + "transform" -: "translate(-50%, -25%)" + zIndex 1 + backgroundColor white + sym borderRadius (px 5) + boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) + + ".form" ? Form.design + + ".paymentModal" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentModal" <> ".deleteIncomeModal" ? do + h1 ? marginBottom (em 1.5) + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.15) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs new file mode 100644 index 0000000..eef804e --- /dev/null +++ b/server/src/Design/Tooltip.hs @@ -0,0 +1,14 @@ +module Design.Tooltip + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + color Color.white diff --git a/server/src/Design/View/ConfirmDialog.hs b/server/src/Design/View/ConfirmDialog.hs new file mode 100644 index 0000000..410d4d8 --- /dev/null +++ b/server/src/Design/View/ConfirmDialog.hs @@ -0,0 +1,36 @@ +module Design.View.ConfirmDialog + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".confirm" ? do + ".confirmHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".confirmContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs new file mode 100644 index 0000000..609d8fc --- /dev/null +++ b/server/src/Design/View/Header.hs @@ -0,0 +1,78 @@ +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? + backgroundColor (Color.chestnutRose +. 10) + + (".item.current" # hover) <> (".item.current" # focus) ? + backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + display flex + justifyContent center + alignItems center + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs new file mode 100644 index 0000000..150c6fc --- /dev/null +++ b/server/src/Design/View/NotFound.hs @@ -0,0 +1,21 @@ +module Design.View.NotFound + ( design + ) where + +import Clay +import Prelude hiding (rem) + +import qualified Design.Color as Color + +design :: Css +design = do + + marginLeft (rem 3) + + ".link" ? do + display block + marginTop (rem 1) + color Color.chestnutRose + textDecoration underline + hover & + color (Color.chestnutRose +. 15) diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs new file mode 100644 index 0000000..1482ef4 --- /dev/null +++ b/server/src/Design/View/Pages.hs @@ -0,0 +1,55 @@ +module Design.View.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = + ".pages" ? do + display flex + justifyContent center + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs new file mode 100644 index 0000000..d563f5d --- /dev/null +++ b/server/src/Design/View/Payment.hs @@ -0,0 +1,13 @@ +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.HeaderForm as HeaderForm +import qualified Design.View.Payment.HeaderInfos as HeaderInfos + +design :: Css +design = do + HeaderForm.design + HeaderInfos.design diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs new file mode 100644 index 0000000..5ecae7a --- /dev/null +++ b/server/src/Design/View/Payment/Add.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Add + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".addHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".addContent" ? do + sym2 padding (px 20) (px 30) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/Form.hs b/server/src/Design/View/Payment/Form.hs new file mode 100644 index 0000000..aada12b --- /dev/null +++ b/server/src/Design/View/Payment/Form.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Form + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".formHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".formContent" ? do + sym2 padding (px 20) (px 30) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..6081443 --- /dev/null +++ b/server/src/Design/View/Payment/HeaderForm.hs @@ -0,0 +1,40 @@ +module Design.View.Payment.HeaderForm + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderForm" ? do + marginBottom (em 2) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + display flex + justifyContent spaceBetween + alignItems center + Media.mobile $ flexDirection column + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock + Media.mobile $ marginBottom (em 2) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + flexShrink 0 diff --git a/server/src/Design/View/Payment/HeaderInfos.hs b/server/src/Design/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..acb393b --- /dev/null +++ b/server/src/Design/View/Payment/HeaderInfos.hs @@ -0,0 +1,50 @@ +module Design.View.Payment.HeaderInfos + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderInfos" ? do + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + + ".g-PaymentHeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + marginBottom (em 1) + + Media.mobile $ do + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".g-PaymentHeaderInfos__Repartition" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs new file mode 100644 index 0000000..42c9621 --- /dev/null +++ b/server/src/Design/View/SignIn.hs @@ -0,0 +1,36 @@ +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) +import Prelude hiding (rem) + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + let inputHeight = 50 + width (px 350) + sym2 padding (rem 0) (rem 2) + marginTop (px 100) + marginLeft auto + marginRight auto + + button # ".validate" ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs new file mode 100644 index 0000000..2e4ecad --- /dev/null +++ b/server/src/Design/View/Stat.hs @@ -0,0 +1,17 @@ +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) + + ".g-Chart" ? do + width (pct 75) + sym2 margin (px 0) auto diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs new file mode 100644 index 0000000..56bd389 --- /dev/null +++ b/server/src/Design/View/Table.hs @@ -0,0 +1,99 @@ +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".table" ? do + minHeight (px 540) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + svg ? do + "path" ? ("fill" -: Color.toString Color.chestnutRose) + width (px 18) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs new file mode 100644 index 0000000..4552796 --- /dev/null +++ b/server/src/Design/Views.hs @@ -0,0 +1,56 @@ +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.ConfirmDialog as ConfirmDialog +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +design :: Css +design = do + header ? Header.design + Payment.design + ".signIn" ? SignIn.design + Stat.design + ".notfound" ? NotFound.design + Table.design + Pages.design + ConfirmDialog.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + display flex + marginBottom (em 1) + + Media.tabletDesktop $ do + justifyContent spaceBetween + alignItems center + + Media.mobile $ do + flexDirection column + "h1" ? marginBottom (em 0.5) + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow . pure . bsColor (rgba 0 0 0 0.3) $ shadowWithBlur (px 2) (px 2) (px 5) + color Color.white diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs new file mode 100644 index 0000000..d8cd522 --- /dev/null +++ b/server/src/Job/Daemon.hs @@ -0,0 +1,37 @@ +module Job.Daemon + ( runDaemons + ) where + +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) + +import Conf (Conf) +import Job.Frequency (Frequency (..), microSeconds) +import Job.Kind (Kind (..)) +import Job.Model (actualizeLastCheck, actualizeLastExecution, + getLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) + +runDaemons :: Conf -> IO () +runDaemons conf = do + _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment + _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) + return () + +runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId +runDaemon kind frequency isLastExecutionTooOld runJob = + forkIO . forever $ do + mbLastExecution <- Query.run $ do + actualizeLastCheck kind + getLastExecution kind + hasToRun <- case mbLastExecution of + Just lastExecution -> isLastExecutionTooOld lastExecution + Nothing -> return True + if hasToRun + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) + else return () + threadDelay . microSeconds $ frequency diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs new file mode 100644 index 0000000..c5bef42 --- /dev/null +++ b/server/src/Job/Frequency.hs @@ -0,0 +1,13 @@ +module Job.Frequency + ( Frequency(..) + , microSeconds + ) where + +data Frequency = + EveryHour + | EveryDay + deriving (Eq, Read, Show) + +microSeconds :: Frequency -> Int +microSeconds EveryHour = 1000000 * 60 * 60 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..17997f7 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,23 @@ +module Job.Kind + ( Kind(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs new file mode 100644 index 0000000..1dd6c63 --- /dev/null +++ b/server/src/Job/Model.hs @@ -0,0 +1,49 @@ +module Job.Model + ( Job(..) + , getLastExecution + , actualizeLastExecution + , actualizeLastCheck + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Job.Kind +import Model.Query (Query (Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..dfbe8b4 --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Util.Time as Time + +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName + now <- getCurrentTime + actualDay <- Time.timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (PaymentPersistence.createMany punctualPayments) + return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..ff80ddf --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,51 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +import qualified Data.Map as M +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (User (..)) + +import Conf (Conf) +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + + case mbLastExecution of + Nothing -> + return () + + Just lastExecution -> do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty + weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) + + return () + + return now diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs new file mode 100644 index 0000000..86f1329 --- /dev/null +++ b/server/src/LoginSession.hs @@ -0,0 +1,52 @@ +module LoginSession + ( put + , get + , delete + ) where + +import Cookie (deleteCookie, getCookie, + setSimpleCookie) +import qualified Web.ClientSession as CS +import Web.Scotty (ActionM) + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Conf (Conf) + +sessionName :: Text +sessionName = "SESSION" + +sessionKeyFile :: FilePath +sessionKeyFile = "sessionKey" + +put :: Conf -> Text -> ActionM () +put conf value = do + encrypted <- liftIO $ encrypt value + setSimpleCookie conf sessionName encrypted + +encrypt :: Text -> IO Text +encrypt value = do + iv <- CS.randomIV + key <- CS.getKey sessionKeyFile + return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) + +get :: ActionM (Maybe Text) +get = do + maybeEncrypted <- getCookie sessionName + case maybeEncrypted of + Just encrypted -> + liftIO $ decrypt encrypted + Nothing -> + return Nothing + +decrypt :: Text -> IO (Maybe Text) +decrypt encrypted = do + key <- CS.getKey sessionKeyFile + let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) + return decrypted + +delete :: Conf -> ActionM () +delete conf = deleteCookie conf sessionName diff --git a/server/src/Main.hs b/server/src/Main.hs new file mode 100644 index 0000000..659a0fa --- /dev/null +++ b/server/src/Main.hs @@ -0,0 +1,106 @@ +module Main + ( main + ) where + +import qualified Network.HTTP.Types.Status as Status +import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) +import qualified Network.Wai.Middleware.Gzip as W +import Network.Wai.Middleware.Static +import qualified Web.Scotty as S + +import qualified Conf +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.Statistics as Statistics +import qualified Controller.User as User +import qualified Design.Global as Design +import Job.Daemon (runDaemons) + +main :: IO () +main = do + conf <- Conf.get "application.conf" + putStrLn . show $ conf + _ <- runDaemons conf + S.scotty (Conf.port conf) $ do + + S.middleware $ + W.gzip $ W.def { W.gzipFiles = GzipCompress } + + S.middleware . staticPolicy $ + noDots >-> addBase "public" + + S.get "/css/main.css" $ do + S.setHeader "Content-Type" "text/css" + S.text Design.globalDesign + + S.post "/api/signIn" $ + S.jsonData >>= Index.signIn conf + + S.post "/api/signOut" $ + Index.signOut conf + + S.get "/api/users"$ + User.list + + S.get "/api/payments" $ do + frequency <- S.param "frequency" + page <- S.param "page" + perPage <- S.param "perPage" + search <- S.param "search" + Payment.list (read frequency) page perPage search + + S.get "/api/payment/category" $ do + name <- S.param "name" + Payment.searchCategory name + + S.post "/api/payment" $ + S.jsonData >>= Payment.create + + S.put "/api/payment" $ + S.jsonData >>= Payment.edit + + S.delete "/api/payment/:id" $ do + paymentId <- S.param "id" + Payment.delete paymentId + + S.get "/api/incomes" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Income.list page perPage + + S.post "/api/income" $ + S.jsonData >>= Income.create + + S.put "/api/income" $ + S.jsonData >>= Income.edit + + S.delete "/api/income/:id" $ do + incomeId <- S.param "id" + Income.delete incomeId + + S.get "/api/allCategories" $ do + Category.listAll + + S.get "/api/categories" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Category.list page perPage + + S.post "/api/category" $ + S.jsonData >>= Category.create + + S.put "/api/category" $ + S.jsonData >>= Category.edit + + S.delete "/api/category/:id" $ do + categoryId <- S.param "id" + Category.delete categoryId + + S.get "/api/statistics" $ do + Statistics.paymentsAndIncomes + + S.notFound $ do + S.status Status.ok200 + Index.get conf diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs new file mode 100644 index 0000000..dae061b --- /dev/null +++ b/server/src/Model/CreateCategory.hs @@ -0,0 +1,10 @@ +module Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Text (Text) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/CreateIncome.hs b/server/src/Model/CreateIncome.hs new file mode 100644 index 0000000..82451d2 --- /dev/null +++ b/server/src/Model/CreateIncome.hs @@ -0,0 +1,10 @@ +module Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Time.Calendar (Day) + +data CreateIncome = CreateIncome + { _createIncome_amount :: Int + , _createIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs new file mode 100644 index 0000000..b25d2a4 --- /dev/null +++ b/server/src/Model/CreatePayment.hs @@ -0,0 +1,16 @@ +module Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs new file mode 100644 index 0000000..8ee26ac --- /dev/null +++ b/server/src/Model/EditCategory.hs @@ -0,0 +1,13 @@ +module Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Text (Text) + +import Common.Model (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/EditIncome.hs b/server/src/Model/EditIncome.hs new file mode 100644 index 0000000..ac3d311 --- /dev/null +++ b/server/src/Model/EditIncome.hs @@ -0,0 +1,13 @@ +module Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Time.Calendar (Day) + +import Common.Model (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_amount :: Int + , _editIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs new file mode 100644 index 0000000..ac4c906 --- /dev/null +++ b/server/src/Model/EditPayment.hs @@ -0,0 +1,17 @@ +module Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency, PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs new file mode 100644 index 0000000..c71e372 --- /dev/null +++ b/server/src/Model/HashedPassword.hs @@ -0,0 +1,27 @@ +module Model.HashedPassword + ( hash + , check + , HashedPassword(..) + ) where + +import qualified Crypto.BCrypt as BCrypt +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Common.Model.Password (Password (..)) + +newtype HashedPassword = HashedPassword Text deriving (Show) + +hash :: Password -> IO (Maybe HashedPassword) +hash (Password p) = do + hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p) + case hashed of + Nothing -> + return Nothing + + Just h -> + return . Just . HashedPassword . TE.decodeUtf8 $ h + +check :: Password -> HashedPassword -> Bool +check (Password p) (HashedPassword h) = + BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p) diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs new file mode 100644 index 0000000..6ab5f18 --- /dev/null +++ b/server/src/Model/IncomeResource.hs @@ -0,0 +1,15 @@ +module Model.IncomeResource + ( IncomeResource(..) + ) where + +import Common.Model (Income (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype IncomeResource = IncomeResource Income + +instance Resource IncomeResource where + resourceCreatedAt (IncomeResource i) = _income_createdAt i + resourceEditedAt (IncomeResource i) = _income_editedAt i + resourceDeletedAt (IncomeResource i) = _income_deletedAt i diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs new file mode 100644 index 0000000..780efcc --- /dev/null +++ b/server/src/Model/Mail.hs @@ -0,0 +1,12 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) + +data Mail = Mail + { from :: Text + , to :: [Text] + , subject :: Text + , body :: Text + } deriving (Eq, Show) diff --git a/server/src/Model/PaymentResource.hs b/server/src/Model/PaymentResource.hs new file mode 100644 index 0000000..1ea978c --- /dev/null +++ b/server/src/Model/PaymentResource.hs @@ -0,0 +1,15 @@ +module Model.PaymentResource + ( PaymentResource(..) + ) where + +import Common.Model (Payment (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype PaymentResource = PaymentResource Payment + +instance Resource PaymentResource where + resourceCreatedAt (PaymentResource p) = _payment_createdAt p + resourceEditedAt (PaymentResource p) = _payment_editedAt p + resourceDeletedAt (PaymentResource p) = _payment_deletedAt p diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs new file mode 100644 index 0000000..22ae95b --- /dev/null +++ b/server/src/Model/Query.hs @@ -0,0 +1,32 @@ +module Model.Query + ( Query(..) + , run + ) where + +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) +import qualified Database.SQLite.Simple as SQLite + +data Query a = Query (Connection -> IO a) + +instance Functor Query where + fmap f (Query call) = Query (fmap f . call) + +instance Applicative Query where + pure x = Query (const $ return x) + (Query callF) <*> (Query callX) = Query (\conn -> do + x <- callX conn + f <- callF conn + return (f x)) + +instance Monad Query where + (Query callX) >>= f = Query (\conn -> do + x <- callX conn + case f x of Query callY -> callY conn) + +run :: Query a -> IO a +run (Query call) = do + conn <- SQLite.open "database" + result <- call conn + _ <- SQLite.close conn + return result diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs new file mode 100644 index 0000000..a217bae --- /dev/null +++ b/server/src/Model/SignIn.hs @@ -0,0 +1,10 @@ +module Model.SignIn + ( SignIn(..) + ) where + +import Common.Model (Email, Password) + +data SignIn = SignIn + { _signIn_email :: Email + , _signIn_password :: Password + } deriving Show diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs new file mode 100644 index 0000000..0959a8e --- /dev/null +++ b/server/src/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.Text (Text, pack) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Payer.hs b/server/src/Payer.hs new file mode 100644 index 0000000..ab8312e --- /dev/null +++ b/server/src/Payer.hs @@ -0,0 +1,87 @@ +module Payer + ( getExceedingPayers + ) where + +import Data.Map (Map) +import qualified Data.Map as M + +import Common.Model (ExceedingPayer (..), User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_income :: Int + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = + let userIds = map _user_id users + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition = + flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition + , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition + , _payer_income = M.findWithDefault 0 userId cumulativeIncome + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) + } + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs new file mode 100644 index 0000000..b0a6fca --- /dev/null +++ b/server/src/Persistence/Category.hs @@ -0,0 +1,123 @@ +module Persistence.Category + ( count + , list + , listAll + , create + , edit + , delete + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category (..), CategoryId) + +import Model.Query (Query (Query)) + +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL" + ) + + +list :: Int -> Int -> Query [Category] +list page perPage = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.queryNamed + conn + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listAll :: Query [Category] +listAll = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query () +create name color = + Query (\conn -> do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)" + [ ":name" := name + , ":color" := color + , ":created_at" := currentTime + ] + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit id name color = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> + (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ]) + if Maybe.isJust mbCategory + then do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id" + [ ":editedAt" := currentTime + , ":name" := name + , ":color" := color + , ":id" := id + ] + return True + else + return False + ) + +data BoolRow = BoolRow Int + +instance FromRow BoolRow where + fromRow = BoolRow <$> SQLite.field + +delete :: CategoryId -> Query Bool +delete id = + Query (\conn -> do + mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$> + (SQLite.queryNamed + conn + "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL" + [ ":id" := id ]) + if Maybe.isNothing mbPayment + then do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL" + [ ":deletedAt" := currentTime + , ":id" := id + ] + return True + else + return False + ) diff --git a/server/src/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs new file mode 100644 index 0000000..edaa844 --- /dev/null +++ b/server/src/Persistence/Frequency.hs @@ -0,0 +1,23 @@ +module Persistence.Frequency + ( FrequencyField(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +import Common.Model (Frequency) + +newtype FrequencyField = FrequencyField Frequency + +instance FromField FrequencyField where + fromField field = + case fieldData field of + SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency)) + _ -> Errors [error "SQLText field required for frequency"] + +instance ToField FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs new file mode 100644 index 0000000..1b5364c --- /dev/null +++ b/server/src/Persistence/Income.hs @@ -0,0 +1,201 @@ +module Persistence.Income + ( listAll + , count + , list + , listModifiedSince + , create + , edit + , delete + , definedForAll + , getCumulativeIncome + ) where + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id, until) + +import Common.Model (Income (..), IncomeId, PaymentId, + UserId) + +import Model.Query (Query (Query)) + +newtype Row = Row Income + +instance FromRow Row where + fromRow = Row <$> (Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC" + ) + + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" + ) + +list :: Int -> Int -> Query [Income] +list page perPage = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listModifiedSince :: UTCTime -> Query [Income] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM income" + , "WHERE" + , "created_at >= :since" + , "OR edited_at >= :since" + , "OR deleted_at >= :since" + ]) + [ ":since" := since ] + ) + +create :: UserId -> Day -> Int -> Query () +create userId date amount = + Query (\conn -> do + createdAt <- getCurrentTime + SQLite.executeNamed + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (:userId, :date, :amount, :createdAt)" + [ ":userId" := userId + , ":date" := date + , ":amount" := amount + , ":createdAt" := createdAt + ] + ) + +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool +edit userId id date amount = + Query (\conn -> do + income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> + SQLite.queryNamed conn "SELECT * FROM income WHERE id = :id" [ ":id" := id ] + if Maybe.isJust income then + do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE income SET edited_at = :editedAt, date = :date, amount = :amount WHERE id = :id AND user_id = :userId" + [ ":editedAt" := currentTime + , ":date" := date + , ":amount" := amount + , ":id" := id + , ":userId" := userId + ] + return True + else + return False + ) + +delete :: UserId -> PaymentId -> Query () +delete userId id = + Query (\conn -> + SQLite.executeNamed + conn + "UPDATE income SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := id + , ":userId" := userId + ] + ) + +data UserDayRow = UserDayRow (UserId, Day) + +instance FromRow UserDayRow where + fromRow = do + user <- SQLite.field + day <- SQLite.field + return $ UserDayRow (user, day) + +definedForAll :: [UserId] -> Query (Maybe Day) +definedForAll users = + Query (\conn -> + (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$> + SQLite.query_ + conn + "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;" + ) + where + fromRows rows = + if L.sort users == L.sort (map fst rows) then + Maybe.listToMaybe . reverse . L.sort . map snd $ rows + else + Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs new file mode 100644 index 0000000..573d57f --- /dev/null +++ b/server/src/Persistence/Payment.hs @@ -0,0 +1,389 @@ +module Persistence.Payment + ( count + , find + , getRange + , listAllPunctual + , listActivePage + , listModifiedPunctualSince + , listActiveMonthlyOrderedByName + , create + , createMany + , edit + , delete + , searchCategory + , repartition + , getPreAndPostPaymentRepartition + , usedCategories + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), + NamedParam ((:=)), ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id, until) + +import Common.Model (CategoryId, Frequency (..), + Payment (..), PaymentId, + User (..), UserId) +import qualified Common.Util.Text as TextUtil + +import Model.Query (Query (Query)) +import Persistence.Frequency (FrequencyField (..)) +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Util as PersistenceUtil + + +fields :: Text +fields = T.intercalate "," $ + [ "id" + , "user_id" + , "name" + , "cost" + , "date" + , "category" + , "frequency" + , "created_at" + , "edited_at" + , "deleted_at" + ] + +newtype Row = Row Payment + +instance FromRow Row where + fromRow = Row <$> (Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +newtype InsertRow = InsertRow Payment + +instance ToRow InsertRow where + toRow (InsertRow p) = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_category p) + , toField (FrequencyField (_payment_frequency p)) + , toField (_payment_createdAt p) + ] + +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Frequency -> Text -> Query Int +count frequency search = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT COUNT(*)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + ]) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + ] + ) + +find :: PaymentId -> Query (Maybe Payment) +find paymentId = + Query (\conn -> do + fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = :id") + [ "id" := paymentId + ] + ) + +data RangeRow = RangeRow (Day, Day) + +instance FromRow RangeRow where + fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field + +getRange :: Query (Maybe (Day, Day)) +getRange = + Query (\conn -> do + fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT MIN(date), MAX(date)" + , "FROM payment" + , "WHERE" + , "frequency = :frequency" + , "AND deleted_at IS NULL" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + +listAllPunctual :: Query [Payment] +listAllPunctual = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY date" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + + +listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] +listActivePage frequency page perPage search = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "ORDER BY date DESC" + , "LIMIT :limit" + , "OFFSET :offset" + ] + ) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listModifiedPunctualSince :: UTCTime -> Query [Payment] +listModifiedPunctualSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT " <> fields + , "FROM payment" + , "WHERE" + , "frequency = :frequency" + , "AND (created_at >= :since OR edited_at >= :since OR deleted_at >= :since)" + ]) + [ ":frequency" := FrequencyField Punctual + , ":since" := since + ] + ) + + +listActiveMonthlyOrderedByName :: Query [Payment] +listActiveMonthlyOrderedByName = + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY name DESC" + ]) + [ ":frequency" := FrequencyField Monthly + ] + ) + +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () +create userId name cost date category frequency = + Query (\conn -> do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (:userId, :name, :cost, :date, :category, :frequency, :currentTime)" + ]) + [ ":userId" := userId + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":currentTime" := currentTime + ] + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" + ]) + (map InsertRow payments) + ) + +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool +edit userId paymentId name cost date category frequency = + Query (\conn -> do + payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ + "SELECT " <> fields <> " FROM payment WHERE id = :paymentId and user_id = :userId") + [ ":paymentId" := paymentId + , ":userId" := userId + ] + if Maybe.isJust payment then + do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE" + , " payment" + , "SET" + , " edited_at = :editedAt," + , " name = :name," + , " cost = :cost," + , " date = :date," + , " category = :category," + , " frequency = :frequency" + , "WHERE" + , " id = :id" + , " AND user_id = :userId" + ]) + [ ":editedAt" := currentTime + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":id" := paymentId + , ":userId" := userId + ] + return True + else + return False + ) + +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.executeNamed + conn + "UPDATE payment SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := paymentId + , ":userId" := userId + ] + ) + +data CategoryIdRow = CategoryIdRow CategoryId + +instance FromRow CategoryIdRow where + fromRow = CategoryIdRow <$> SQLite.field + +searchCategory :: Text -> Query (Maybe CategoryId) +searchCategory paymentName = + Query (\conn -> + fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE :name" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) + [ ":name" := "%" <> paymentName <> "%" + ] + ) + +usedCategories :: Query [CategoryId] +usedCategories = + Query (\conn -> do + map (\(CategoryIdRow p) -> p) <$> + SQLite.query_ + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT DISTINCT category" + , "FROM payment" + , "WHERE deleted_at IS NULL" + ]) + ) + +data UserCostRow = UserCostRow (UserId, Int) + +instance FromRow UserCostRow where + fromRow = do + user <- SQLite.field + cost <- SQLite.field + return $ UserCostRow (user, cost) + +repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) +repartition frequency search from to = + Query (\conn -> + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT user_id, SUM(cost)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "AND date >= :from" + , "AND date < :to" + , "GROUP BY user_id" + ]) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":from" := from + , ":to" := to + ] + ) + +getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) +getPreAndPostPaymentRepartition paymentRange users = do + case paymentRange of + Just (from, to) -> do + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + (,) + <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll)) + <*> (case incomeDefinedForAll of + Just d -> repartition Punctual "" d (Calendar.addDays 1 to) + Nothing -> return M.empty) + + Nothing -> + return (M.empty, M.empty) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs new file mode 100644 index 0000000..12145ac --- /dev/null +++ b/server/src/Persistence/User.hs @@ -0,0 +1,78 @@ +module Persistence.User + ( list + , get + , checkPassword + , createSignInToken + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Email (..), Password (..), User (..)) + +import Model.HashedPassword (HashedPassword (..)) +import qualified Model.HashedPassword as HashedPassword +import Model.Query (Query (Query)) +import qualified Model.UUID as UUID + +newtype Row = Row User + +instance FromRow Row where + fromRow = Row <$> (User <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [User] +list = + Query (\conn -> do + map (\(Row u) -> u) <$> + SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC" + ) + +get :: Text -> Query (Maybe User) +get token = + Query (\conn -> do + fmap (\(Row u) -> u) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1" + [ ":sign_in_token" := token ] + ) + +data HashedPasswordRow = HashedPasswordRow HashedPassword + +instance FromRow HashedPasswordRow where + fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field) + +checkPassword :: Email -> Password -> Query Bool +checkPassword (Email email) password = + Query (\conn -> do + hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT password FROM user WHERE email = :email LIMIT 1" + [ ":email" := email ] + case hashedPassword of + Just h -> + return (HashedPassword.check password h) + + Nothing -> + return False + ) + +createSignInToken :: Email -> Query Text +createSignInToken (Email email) = + Query (\conn -> do + token <- UUID.generateUUID + SQLite.executeNamed + conn + "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email" + [ ":sign_in_token" := token + , ":email" := email + ] + return token + ) diff --git a/server/src/Persistence/Util.hs b/server/src/Persistence/Util.hs new file mode 100644 index 0000000..b7496c6 --- /dev/null +++ b/server/src/Persistence/Util.hs @@ -0,0 +1,11 @@ +module Persistence.Util + ( formatKeyForSearch + ) where + +import Data.Text (Text) + +formatKeyForSearch :: Text -> Text +formatKeyForSearch key = + "replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(" + <> key + <> "), 'à', 'a'), 'â', 'a'), 'ç', 'c'), 'è', 'e'), 'é', 'e'), 'ê', 'e'), 'ë', 'e'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ù', 'u'), 'û', 'u'), 'ü', 'u')" diff --git a/server/src/Resource.hs b/server/src/Resource.hs new file mode 100644 index 0000000..a12a0f2 --- /dev/null +++ b/server/src/Resource.hs @@ -0,0 +1,54 @@ +module Resource + ( Resource + , resourceCreatedAt + , resourceEditedAt + , resourceDeletedAt + , Status(..) + , statuses + , groupByStatus + , statusDuring + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) + +class Resource a where + resourceCreatedAt :: a -> UTCTime + resourceEditedAt :: a -> Maybe UTCTime + resourceDeletedAt :: a -> Maybe UTCTime + +data Status = + Created + | Edited + | Deleted + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +statuses :: [Status] +statuses = [minBound..] + +groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] +groupByStatus start end resources = + foldl + (\m resource -> + case statusDuring start end resource of + Just status -> M.insertWith (++) status [resource] m + Nothing -> m + ) + M.empty + resources + +statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status +statusDuring start end resource + | created && not deleted = Just Created + | not created && edited && not deleted = Just Edited + | not created && deleted = Just Deleted + | otherwise = Nothing + where + created = belongs (resourceCreatedAt resource) start end + edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) + deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) + +belongs :: UTCTime -> UTCTime -> UTCTime -> Bool +belongs time start end = time >= start && time < end diff --git a/server/src/Secure.hs b/server/src/Secure.hs new file mode 100644 index 0000000..a30941f --- /dev/null +++ b/server/src/Secure.hs @@ -0,0 +1,31 @@ +module Secure + ( loggedAction + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import qualified Network.HTTP.Types.Status as HTTP +import Web.Scotty + +import Common.Model (User) +import qualified Common.Msg as Msg + +import qualified LoginSession +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence + +loggedAction :: (User -> ActionM ()) -> ActionM () +loggedAction action = do + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . Query.run . UserPersistence.get $ token + case maybeUser of + Just user -> + action user + Nothing -> do + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized + Nothing -> do + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs new file mode 100644 index 0000000..13d4072 --- /dev/null +++ b/server/src/SendMail.hs @@ -0,0 +1,66 @@ +module SendMail + ( sendMail + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) +import qualified Network.Mail.Mime as M + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) + +import Conf (Conf) +import qualified Conf +import Model.Mail (Mail (..)) + +sendMail :: Conf -> Mail -> IO (Either Text ()) +sendMail conf mail = + if Conf.devMode conf + then + do + T.putStrLn . mockMailMessage $ mail + return (Right ()) + else + do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else return () + return result + +mockMailMessage :: Mail -> Text +mockMailMessage mail = T.concat $ + [ "[MOCK MAIL] " + , subject mail + , " (from: " + , from mail + , ") (to: " + , T.intercalate ", " $ to mail + , ")" + , "\n" + , body mail + , "\n" + ] + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = + let fromMail = M.emptyMail (address mailFrom) + in fromMail + { M.mailTo = map address mailTo + , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] + , M.mailHeaders = [("Subject", mailSubject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs new file mode 100644 index 0000000..e463aac --- /dev/null +++ b/server/src/Statistics.hs @@ -0,0 +1,59 @@ +module Statistics + ( paymentsAndIncomes + ) where + +import Control.Arrow ((&&&)) +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Time.Calendar as Calendar + +import Common.Model (Income (..), MonthStats (..), Payment (..), + Stats) + +paymentsAndIncomes :: [Payment] -> [Income] -> Stats +paymentsAndIncomes payments incomes = + + map toMonthStat . M.toList $ foldl + (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) + M.empty + payments + + where + + toMonthStat (start, paymentsByCategory) = + MonthStats start paymentsByCategory (incomesAt start) + + incomesAt day = + M.map (incomeAt day) lastToFirstIncomesByUser + + incomeAt day lastToFirstIncome = + Maybe.maybe 0 _income_amount + . Maybe.listToMaybe + . dropWhile (\i -> _income_date i > day) + $ lastToFirstIncome + + lastToFirstIncomesByUser = + M.map (reverse . L.sortOn _income_date) + . groupBy _income_userId + $ incomes + + initMonthStats = + M.fromList + . map (\category -> (category, 0)) + . L.nub + $ map _payment_category payments + + alter p Nothing = Just (addPayment p initMonthStats) + alter p (Just monthStats) = Just (addPayment p monthStats) + + addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats + + startOfMonth day = + let (y, m, _) = Calendar.toGregorian day + in Calendar.fromGregorian y m 1 + +groupBy :: Ord k => (a -> k) -> [a] -> Map k [a] +groupBy key = + M.fromListWith (++) . map (key &&& pure) diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs new file mode 100644 index 0000000..4a29fcc --- /dev/null +++ b/server/src/Util/Time.hs @@ -0,0 +1,22 @@ +module Util.Time + ( belongToCurrentMonth + , belongToCurrentWeek + ) where + +import Data.Time.Calendar (toGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) + +import qualified Common.Util.Time as Time + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs new file mode 100644 index 0000000..12f2117 --- /dev/null +++ b/server/src/Validation/Category.hs @@ -0,0 +1,27 @@ +module Validation.Category + ( createCategory + , editCategory + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Validation.Category as CategoryValidation +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) + +createCategory :: CreateCategoryForm -> Validation Text CreateCategory +createCategory form = + CreateCategory + <$> CategoryValidation.name (_createCategoryForm_name form) + <*> CategoryValidation.color (_createCategoryForm_color form) + +editCategory :: EditCategoryForm -> Validation Text EditCategory +editCategory form = + EditCategory + <$> V.Success (_editCategoryForm_id form) + <*> CategoryValidation.name (_editCategoryForm_name form) + <*> CategoryValidation.color (_editCategoryForm_color form) diff --git a/server/src/Validation/Income.hs b/server/src/Validation/Income.hs new file mode 100644 index 0000000..5e034d1 --- /dev/null +++ b/server/src/Validation/Income.hs @@ -0,0 +1,27 @@ +module Validation.Income + ( createIncome + , editIncome + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..)) +import qualified Common.Validation.Income as IncomeValidation +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) + +createIncome :: CreateIncomeForm -> Validation Text CreateIncome +createIncome form = + CreateIncome + <$> IncomeValidation.amount (_createIncomeForm_amount form) + <*> IncomeValidation.date (_createIncomeForm_date form) + +editIncome :: EditIncomeForm -> Validation Text EditIncome +editIncome form = + EditIncome + <$> V.Success (_editIncomeForm_id form) + <*> IncomeValidation.amount (_editIncomeForm_amount form) + <*> IncomeValidation.date (_editIncomeForm_date form) diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs new file mode 100644 index 0000000..20e370e --- /dev/null +++ b/server/src/Validation/Payment.hs @@ -0,0 +1,33 @@ +module Validation.Payment + ( createPayment + , editPayment + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CategoryId, CreatePaymentForm (..), + EditPaymentForm (..)) +import qualified Common.Validation.Payment as PaymentValidation +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) + +createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment +createPayment categories form = + CreatePayment + <$> PaymentValidation.name (_createPaymentForm_name form) + <*> PaymentValidation.cost (_createPaymentForm_cost form) + <*> PaymentValidation.date (_createPaymentForm_date form) + <*> PaymentValidation.category categories (_createPaymentForm_category form) + <*> V.Success (_createPaymentForm_frequency form) + +editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment +editPayment categories form = + EditPayment + <$> V.Success (_editPaymentForm_id form) + <*> PaymentValidation.name (_editPaymentForm_name form) + <*> PaymentValidation.cost (_editPaymentForm_cost form) + <*> PaymentValidation.date (_editPaymentForm_date form) + <*> PaymentValidation.category categories (_editPaymentForm_category form) + <*> V.Success (_editPaymentForm_frequency form) diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs new file mode 100644 index 0000000..dc86122 --- /dev/null +++ b/server/src/Validation/SignIn.hs @@ -0,0 +1,16 @@ +module Validation.SignIn + ( signIn + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model (SignInForm (..)) +import qualified Common.Validation.SignIn as SignInValidation +import Model.SignIn (SignIn (..)) + +signIn :: SignInForm -> Validation Text SignIn +signIn form = + SignIn + <$> SignInValidation.email (_signInForm_email form) + <*> SignInValidation.password (_signInForm_password form) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..3fe224f --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,124 @@ +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) + +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import Conf (Conf) +import qualified Conf as Conf +import Model.IncomeResource (IncomeResource (..)) +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer +import Resource (Status (..), groupByStatus, statuses) + +mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Msg.get Msg.App_Title + , " − " + , Msg.get Msg.WeeklyReport_Title + ] + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end + } + +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + T.intercalate "\n" $ + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition + , operations conf users paymentsGroupedByStatus incomesGroupedByStatus + ] + where + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes + +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = + T.intercalate "\n" . map formatPayer $ payers + where + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition + formatPayer p = T.concat + [ " * " + , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users + , " + " + , Format.price (Conf.currency conf) $ _exceedingPayer_amount p + , "\n" + ] + +operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text +operations conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Msg.get Msg.WeeklyReport_Empty + else + T.intercalate "\n" . catMaybes . concat $ + [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses + , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses + ] + +paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" * " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..ae7a266 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +module View.Page + ( page + ) where + +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) + +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A + +import Common.Model (Init) +import qualified Common.Msg as Msg + +page :: Maybe Init -> Text +page init = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Msg.get Msg.App_Title) + script ! src "/javascript/main.js" $ "" + script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ "" + jsonScript "init" init + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" + link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" + H.body $ do + H.div ! A.class_ "spinner" $ "" + + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json |