From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Sep 2017 22:14:48 +0200 Subject: Bootstrap with GHCJS and reflex: - setup login and logout, - first draft of payment view. --- src/server/Common | 1 + src/server/Conf.hs | 6 +- src/server/Controller/Category.hs | 12 +- src/server/Controller/Income.hs | 23 +- src/server/Controller/Index.hs | 30 +- src/server/Controller/Payment.hs | 25 +- src/server/Controller/SignIn.hs | 34 +- src/server/Controller/User.hs | 20 - src/server/Design/Color.hs | 3 + src/server/Design/Global.hs | 11 +- src/server/Design/Header.hs | 74 --- src/server/Design/Helper.hs | 46 +- src/server/Design/LoggedIn.hs | 45 -- src/server/Design/LoggedIn/Home.hs | 17 - src/server/Design/LoggedIn/Home/Header.hs | 84 ---- src/server/Design/LoggedIn/Home/Pages.hs | 54 --- src/server/Design/LoggedIn/Home/Table.hs | 37 -- src/server/Design/LoggedIn/Stat.hs | 15 - src/server/Design/LoggedIn/Table.hs | 84 ---- src/server/Design/SignIn.hs | 40 -- src/server/Design/View/Header.hs | 78 ++++ src/server/Design/View/Payment.hs | 17 + src/server/Design/View/Payment/Header.hs | 84 ++++ src/server/Design/View/Payment/Pages.hs | 54 +++ src/server/Design/View/Payment/Table.hs | 42 ++ src/server/Design/View/SignIn.hs | 42 ++ src/server/Design/View/Stat.hs | 15 + src/server/Design/View/Table.hs | 84 ++++ src/server/Design/Views.hs | 49 ++ src/server/Job/MonthlyPayment.hs | 11 +- src/server/Main.hs | 21 +- src/server/Model/Category.hs | 23 +- src/server/Model/Frequency.hs | 23 +- src/server/Model/Income.hs | 32 +- src/server/Model/Init.hs | 31 +- src/server/Model/Json/Category.hs | 24 - src/server/Model/Json/Conf.hs | 17 - src/server/Model/Json/CreateCategory.hs | 17 - src/server/Model/Json/CreateIncome.hs | 17 - src/server/Model/Json/CreatePayment.hs | 23 - src/server/Model/Json/EditCategory.hs | 19 - src/server/Model/Json/EditIncome.hs | 20 - src/server/Model/Json/EditPayment.hs | 25 - src/server/Model/Json/Income.hs | 26 -- src/server/Model/Json/Init.hs | 36 -- src/server/Model/Json/MessagePart.hs | 18 - src/server/Model/Json/Number.hs | 15 - src/server/Model/Json/Payment.hs | 40 -- src/server/Model/Json/PaymentCategory.hs | 23 - src/server/Model/Json/Translation.hs | 20 - src/server/Model/Json/User.hs | 25 - src/server/Model/Message.hs | 35 -- src/server/Model/Message/Key.hs | 193 -------- src/server/Model/Message/Lang.hs | 11 - src/server/Model/Message/Parts.hs | 37 -- src/server/Model/Message/Translations.hs | 729 ------------------------------ src/server/Model/Payer.hs | 216 +++++++++ src/server/Model/Payment.hs | 59 +-- src/server/Model/PaymentCategory.hs | 24 +- src/server/Model/User.hs | 31 +- src/server/Secure.hs | 13 +- src/server/Utils/Text.hs | 41 -- src/server/Utils/Time.hs | 19 - src/server/View/Format.hs | 33 -- src/server/View/Mail/SignIn.hs | 11 +- src/server/View/Mail/WeeklyReport.hs | 110 ++--- src/server/View/Page.hs | 23 +- 67 files changed, 950 insertions(+), 2267 deletions(-) create mode 120000 src/server/Common delete mode 100644 src/server/Controller/User.hs delete mode 100644 src/server/Design/Header.hs delete mode 100644 src/server/Design/LoggedIn.hs delete mode 100644 src/server/Design/LoggedIn/Home.hs delete mode 100644 src/server/Design/LoggedIn/Home/Header.hs delete mode 100644 src/server/Design/LoggedIn/Home/Pages.hs delete mode 100644 src/server/Design/LoggedIn/Home/Table.hs delete mode 100644 src/server/Design/LoggedIn/Stat.hs delete mode 100644 src/server/Design/LoggedIn/Table.hs delete mode 100644 src/server/Design/SignIn.hs create mode 100644 src/server/Design/View/Header.hs create mode 100644 src/server/Design/View/Payment.hs create mode 100644 src/server/Design/View/Payment/Header.hs create mode 100644 src/server/Design/View/Payment/Pages.hs create mode 100644 src/server/Design/View/Payment/Table.hs create mode 100644 src/server/Design/View/SignIn.hs create mode 100644 src/server/Design/View/Stat.hs create mode 100644 src/server/Design/View/Table.hs create mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Model/Json/Category.hs delete mode 100644 src/server/Model/Json/Conf.hs delete mode 100644 src/server/Model/Json/CreateCategory.hs delete mode 100644 src/server/Model/Json/CreateIncome.hs delete mode 100644 src/server/Model/Json/CreatePayment.hs delete mode 100644 src/server/Model/Json/EditCategory.hs delete mode 100644 src/server/Model/Json/EditIncome.hs delete mode 100644 src/server/Model/Json/EditPayment.hs delete mode 100644 src/server/Model/Json/Income.hs delete mode 100644 src/server/Model/Json/Init.hs delete mode 100644 src/server/Model/Json/MessagePart.hs delete mode 100644 src/server/Model/Json/Number.hs delete mode 100644 src/server/Model/Json/Payment.hs delete mode 100644 src/server/Model/Json/PaymentCategory.hs delete mode 100644 src/server/Model/Json/Translation.hs delete mode 100644 src/server/Model/Json/User.hs delete mode 100644 src/server/Model/Message.hs delete mode 100644 src/server/Model/Message/Key.hs delete mode 100644 src/server/Model/Message/Lang.hs delete mode 100644 src/server/Model/Message/Parts.hs delete mode 100644 src/server/Model/Message/Translations.hs create mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Utils/Text.hs delete mode 100644 src/server/View/Format.hs (limited to 'src/server') diff --git a/src/server/Common b/src/server/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/server/Common @@ -0,0 +1 @@ +../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs index a05349d..92df4e9 100644 --- a/src/server/Conf.hs +++ b/src/server/Conf.hs @@ -10,11 +10,13 @@ import qualified Data.Text as T import qualified Data.ConfigManager as Conf import Data.Time.Clock (NominalDiffTime) +import Common.Model.Currency (Currency(..)) + data Conf = Conf { hostname :: Text , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text + , currency :: Currency , noReplyMail :: Text , https :: Bool } deriving Show @@ -28,7 +30,7 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> Conf.lookup "https" conf ) diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) +import Common.Model.Category (CategoryId) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.CreateCategory as Json +import qualified Common.Model.EditCategory as Json + import Json (jsonId) -import Model.Category (CategoryId) import qualified Model.Category as Category -import qualified Model.Json.CreateCategory as Json -import qualified Model.Json.EditCategory as Json -import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query import qualified Secure @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + import Json (jsonId) -import Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Json.CreateIncome as Json -import qualified Model.Json.EditIncome as Json -import qualified Model.Message.Key as Key import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure -create :: Json.CreateIncome -> ActionM () -create (Json.CreateIncome date amount) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId ) -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.EditIncome incomeId date amount) = +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) import Web.Scotty hiding (get) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + import Conf (Conf(..)) import Model.Init (getInit) -import Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty +import qualified Common.Model.CreatePayment as M +import qualified Common.Model.EditPayment as M +import Common.Model (PaymentId, User(..)) + import Json (jsonId) -import Model.Payment (PaymentId) -import qualified Model.Json.CreatePayment as Json -import qualified Model.Json.EditPayment as Json -import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +create :: M.CreatePayment -> ActionM () +create (M.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do PaymentCategory.save name category - Payment.create (User.id user) name cost date frequency + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +editOwn :: M.EditPayment -> ActionM () +editOwn (M.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (User.id user) paymentId name cost date frequency + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.SignIn as M + import Conf (Conf) -import Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn -signIn :: Conf -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + token <- liftIO . Query.run $ SignIn.createSignInToken email let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, "?signInToken=", token ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index afc601f..06c468e 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -7,6 +7,9 @@ import qualified Clay.Color as C white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index e742978..47ea4a9 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -8,9 +8,7 @@ import Clay import Data.Text.Lazy (Text) -import qualified Design.Header as Header -import qualified Design.SignIn as SignIn -import qualified Design.LoggedIn as LoggedIn +import qualified Design.Views as Views import qualified Design.Form as Form import qualified Design.Errors as Errors import qualified Design.Dialog as Dialog @@ -26,13 +24,10 @@ globalDesign = renderWith compact [] global global :: Css global = do - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design ".errors" ? Errors.design ".dialog" ? Dialog.design ".tooltip" ? Tooltip.design + Views.design Form.design body ? do @@ -49,6 +44,8 @@ global = do a ? cursor pointer + input ? fontSize inherit + h1 ? do color Color.chestnutRose marginBottom (em 1) diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs deleted file mode 100644 index 8feac64..0000000 --- a/src/server/Design/Header.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.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 - height (pct 100) - 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 - heightMedia - svg ? do - Media.mobile $ width (px 20) - -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/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index 869616d..41528ed 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -3,8 +3,8 @@ module Design.Helper ( clearFix , button + , waitable , input - , iconButton , centeredWithMargin , verticalCentering ) where @@ -13,8 +13,6 @@ import Prelude hiding (span) import Clay hiding (button, input) -import Data.Monoid ((<>)) - import Design.Constants import Design.Color as Color @@ -27,6 +25,9 @@ clearFix = 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 @@ -38,19 +39,20 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) + waitable -iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css -iconButton backgroundCol textCol h focusOp = do - button backgroundCol textCol h focusOp - i <> span ? do - height h - lineHeight h - span ? do - display inlineBlock - marginLeft (px 20) - i ? do - marginLeft (px 15) - marginRight (px 20) +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation input :: Double -> Css input h = do @@ -72,3 +74,17 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs deleted file mode 100644 index 4a21832..0000000 --- a/src/server/Design/LoggedIn.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Stat as Stat -import qualified Design.LoggedIn.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".home" ? Home.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Design/LoggedIn/Home.hs b/src/server/Design/LoggedIn/Home.hs deleted file mode 100644 index 7845434..0000000 --- a/src/server/Design/LoggedIn/Home.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home.Header as Header -import qualified Design.LoggedIn.Home.Table as Table -import qualified Design.LoggedIn.Home.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/LoggedIn/Home/Header.hs deleted file mode 100644 index 5fd2d79..0000000 --- a/src/server/Design/LoggedIn/Home/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".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) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? 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/src/server/Design/LoggedIn/Home/Pages.hs b/src/server/Design/LoggedIn/Home/Pages.hs deleted file mode 100644 index 71f3254..0000000 --- a/src/server/Design/LoggedIn/Home/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - 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) - - ".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/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs deleted file mode 100644 index cb46ac9..0000000 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Table - ( design - ) where - -import Clay - -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - 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) diff --git a/src/server/Design/LoggedIn/Stat.hs b/src/server/Design/LoggedIn/Stat.hs deleted file mode 100644 index 62028cb..0000000 --- a/src/server/Design/LoggedIn/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs deleted file mode 100644 index 44b001a..0000000 --- a/src/server/Design/LoggedIn/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.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) - - ".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 - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - 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/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs deleted file mode 100644 index 75f2f98..0000000 --- a/src/server/Design/SignIn.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.SignIn - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - - form ? do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.iconButton Color.gothic Color.white (px inputHeight) Constants.focusLighten - display block - width (pct 100) - fontSize (em 1.2) - ".waitingServer" & ("cursor" -: "not-allowed") - - ".result" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/src/server/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +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 + height (pct 100) + 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 + Helper.waitable + heightMedia + 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/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/src/server/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/src/server/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".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) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? 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/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/src/server/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + 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) + + ".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/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/src/server/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + 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) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/src/server/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? 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/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/src/server/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +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) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/src/server/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +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) + + ".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 + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + 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/src/server/Design/Views.hs b/src/server/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/src/server/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +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 + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index 8c11ccf..ba24cca 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -4,7 +4,8 @@ module Job.MonthlyPayment import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Frequency +import Common.Model (Frequency(..), Payment(..)) + import qualified Model.Payment as Payment import Utils.Time (timeToDay) import qualified Model.Query as Query @@ -14,6 +15,12 @@ monthlyPayment _ = do monthlyPayments <- Query.run Payment.listMonthly now <- getCurrentTime actualDay <- timeToDay now - let punctualPayments = map (\p -> p { Payment.frequency = Punctual, Payment.date = actualDay, Payment.createdAt = now }) monthlyPayments + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments _ <- Query.run (Payment.createMany punctualPayments) return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 17c2594..db73474 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -1,16 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + import Network.Wai.Middleware.Static import qualified Data.Text.Lazy as LT import Web.Scotty -import Job.Daemon (runDaemons) 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.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query main :: IO () main = do @@ -19,13 +28,19 @@ main = do scotty (Conf.port conf) $ do middleware . staticPolicy $ noDots >-> addBase "public" + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + get "/" $ do signInToken <- mbParam "signInToken" Index.get conf signInToken post "/signIn" $ do - email <- param "email" - SignIn.signIn conf email + jsonData >>= SignIn.signIn conf post "/signOut" $ Index.signOut conf diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 9597bd9..6b7a488 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,34 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category - ( CategoryId - , Category(..) - , list + ( list , create , edit , delete ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Model.Query (Query(Query)) - -type CategoryId = Int64 +import Common.Model (Category(..), CategoryId) -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow Category where fromRow = Category <$> diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index f9958e1..4f7b83d 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -1,28 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Model.Frequency - ( Frequency(..) - ) where +module Model.Frequency () where -import Data.Aeson import Database.SQLite.Simple (SQLData(SQLText)) import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) import Database.SQLite.Simple.ToField (ToField(toField)) -import GHC.Generics import qualified Data.Text as T -import Web.Scotty (parseParam, Parsable, readEither) -data Frequency = - Punctual - | Monthly - deriving (Eq, Show, Read, Generic) - -instance Parsable Frequency where parseParam = readEither -instance FromJSON Frequency -instance ToJSON Frequency +import Common.Model.Frequency (Frequency) instance FromField Frequency where fromField field = case fieldData field of diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index c6cdb55..bbe7657 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income - ( IncomeId - , Income(..) - , list + ( list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -18,27 +16,15 @@ import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite +import Common.Model (Income(..), IncomeId, User(..), UserId) + import Model.Query (Query(Query)) -import Model.User (User, UserId) -import qualified Model.User as User import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type IncomeId = Int64 - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Income where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt instance FromRow Income where fromRow = Income <$> @@ -70,7 +56,7 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == incomeUserId + if _income_userId income == incomeUserId then do now <- getCurrentTime SQLite.execute @@ -90,7 +76,7 @@ deleteOwn user incomeId = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == User.id user + if _income_userId income == _user_id user then do now <- getCurrentTime SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 7a9ccea..8c6a961 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,24 @@ module Model.Init ( getInit ) where -import Model.Json.Init (Init) +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf import Model.Query (Query) -import Model.User (User) import qualified Model.Category as Category import qualified Model.Income as Income -import qualified Model.Json.Category as Json -import qualified Model.Json.Income as Json -import qualified Model.Json.Init as Init -import qualified Model.Json.Payment as Json -import qualified Model.Json.PaymentCategory as Json -import qualified Model.Json.User as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.User as User -getInit :: User -> Query Init -getInit user = - Init.Init <$> - (map Json.fromUser <$> User.list) <*> - (return . User.id $ user) <*> - (map Json.fromPayment <$> Payment.list) <*> - (map Json.fromIncome <$> Income.list) <*> - (map Json.fromCategory <$> Category.list) <*> - (map Json.fromPaymentCategory <$> PaymentCategory.list) +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs deleted file mode 100644 index 8b5e527..0000000 --- a/src/server/Model/Json/Category.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Category - ( Category(..) - , fromCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.Category as M - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance ToJSON Category - -fromCategory :: M.Category -> Category -fromCategory category = Category (M.id category) (M.name category) (M.color category) diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs deleted file mode 100644 index a66fb55..0000000 --- a/src/server/Model/Json/Conf.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Conf - ( Conf(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -data Conf = Conf - { currency :: Text - } deriving (Show, Generic) - -instance FromJSON Conf -instance ToJSON Conf diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs deleted file mode 100644 index fffc882..0000000 --- a/src/server/Model/Json/CreateCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateCategory - ( CreateCategory(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text (Text) - -data CreateCategory = CreateCategory - { name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreateIncome.hs b/src/server/Model/Json/CreateIncome.hs deleted file mode 100644 index cf9b1c3..0000000 --- a/src/server/Model/Json/CreateIncome.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateIncome - ( CreateIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -data CreateIncome = CreateIncome - { date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs deleted file mode 100644 index 6ab3a5b..0000000 --- a/src/server/Model/Json/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs deleted file mode 100644 index a10ce39..0000000 --- a/src/server/Model/Json/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) - -data EditCategory = EditCategory - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs deleted file mode 100644 index 9b29379..0000000 --- a/src/server/Model/Json/EditIncome.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditIncome - ( EditIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -import Model.Income (IncomeId) - -data EditIncome = EditIncome - { id :: IncomeId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs deleted file mode 100644 index b7d4d7d..0000000 --- a/src/server/Model/Json/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) -import Model.Payment (PaymentId) - -data EditPayment = EditPayment - { id :: PaymentId - , name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs deleted file mode 100644 index 7e23a84..0000000 --- a/src/server/Model/Json/Income.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Income - ( Income(..) - , fromIncome - ) where - -import Data.Aeson -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Income (IncomeId) -import Model.User (UserId) -import qualified Model.Income as M - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance ToJSON Income - -fromIncome :: M.Income -> Income -fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs deleted file mode 100644 index 530c3b7..0000000 --- a/src/server/Model/Json/Init.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Init - ( Init(..) - , InitResult(..) - ) where - -import Data.Aeson -import GHC.Generics - -import Model.Json.Category (Category) -import Model.Json.Income (Income) -import Model.Json.Payment (Payment) -import Model.Json.PaymentCategory (PaymentCategory) -import Model.Json.User (User) -import Model.Message.Key (Key) -import Model.User (UserId) - -data Init = Init - { users :: [User] - , me :: UserId - , payments :: [Payment] - , incomes :: [Income] - , categories :: [Category] - , paymentCategories :: [PaymentCategory] - } deriving (Show, Generic) - -instance ToJSON Init - -data InitResult = - InitEmpty - | InitSuccess Init - | InitError Key - deriving (Show, Generic) - -instance ToJSON InitResult diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs deleted file mode 100644 index 0753d7c..0000000 --- a/src/server/Model/Json/MessagePart.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.MessagePart - ( MessagePart(..) - ) where - -import Data.Text (Text) - -import Data.Aeson -import GHC.Generics - -data MessagePart = - Order Int - | Str Text - deriving (Eq, Show, Generic) - -instance FromJSON MessagePart -instance ToJSON MessagePart diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs deleted file mode 100644 index 52c9da8..0000000 --- a/src/server/Model/Json/Number.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Number - ( Number(..) - ) where - -import Data.Aeson -import GHC.Generics - -data Number = Number - { number :: Int - } deriving (Show, Generic) - -instance FromJSON Number -instance ToJSON Number diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs deleted file mode 100644 index e406c0f..0000000 --- a/src/server/Model/Json/Payment.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Payment - ( Payment(..) - , fromPayment - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics -import Prelude hiding (id) - -import Model.Frequency -import Model.Payment (PaymentId) -import Model.User (UserId) -import qualified Model.Payment as M - -data Payment = Payment - { id :: PaymentId - , date :: Day - , name :: Text - , cost :: Int - , userId :: UserId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment - -fromPayment :: M.Payment -> Payment -fromPayment payment = - Payment - { id = M.id payment - , date = M.date payment - , name = M.name payment - , cost = M.cost payment - , userId = M.userId payment - , frequency = M.frequency payment - } diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs deleted file mode 100644 index fd97674..0000000 --- a/src/server/Model/Json/PaymentCategory.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentCategory - ( PaymentCategory(..) - , fromPaymentCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.PaymentCategory as M - -data PaymentCategory = PaymentCategory - { name :: Text - , category :: CategoryId - } deriving (Show, Generic) - -instance ToJSON PaymentCategory - -fromPaymentCategory :: M.PaymentCategory -> PaymentCategory -fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc) diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs deleted file mode 100644 index 9dcfe80..0000000 --- a/src/server/Model/Json/Translation.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Translation - ( Translation(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -import Model.Json.MessagePart - -data Translation = Translation - { key :: Text - , message :: [MessagePart] - } deriving (Show, Generic) - -instance FromJSON Translation -instance ToJSON Translation diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs deleted file mode 100644 index c289fe0..0000000 --- a/src/server/Model/Json/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.User - ( User(..) - , fromUser - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.User (UserId) -import qualified Model.User as M - -data User = User - { id :: UserId - , name :: Text - , email :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -fromUser :: M.User -> User -fromUser user = User (M.id user) (M.name user) (M.email user) diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs deleted file mode 100644 index 026967f..0000000 --- a/src/server/Model/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Message - ( getMessage - , getParamMessage - , getTranslations - , plural - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key (Key) -import Model.Message.Lang -import Model.Message.Translations (getNonFormattedMessage) -import Model.Message.Parts - -import Model.Json.Translation - -getMessage :: Key -> Text -getMessage = getParamMessage [] - -getParamMessage :: [Text] -> Key -> Text -getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey) - -getTranslations :: [Translation] -getTranslations = (map getTranslation [minBound..]) - -getTranslation :: Key -> Translation -getTranslation translationKey = - Translation - (T.pack . show $ translationKey) - (getParts $ getNonFormattedMessage lang translationKey) - -plural :: Int -> Key -> Key -> Text -plural count singularKey pluralKey = - getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs deleted file mode 100644 index 18f16f0..0000000 --- a/src/server/Model/Message/Key.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Message.Key - ( Key(..) - ) where - -import qualified Data.Aeson as Json -import qualified Data.Text as T - -data Key = - - -- Title - - SharedCost - - -- Sign - - | Email - | SignIn - | SendEmailFail - | InvalidEmail - | UnauthorizedSignIn - | Forbidden - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid - | SignInMailTitle - | SignInMail - | SignInEmailSent - - -- Dates - - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December - - | ShortDate - | ShortMonthAndYear - | LongDate - - -- Search - - | SearchName - | SearchPunctual - | SearchMonthly - - -- Payments - - | PaymentsAreBalanced - | Name - | Cost - | Payer - | Date - | Frequency - | InvalidFrequency - | AddPayment - | ClonePayment - | EditPayment - | PaymentNotDeleted - | Punctual - | Monthly - - | PaymentsTitle - | Payment - | Payments - | Worth - | NoPayment - - | PaymentName - | PaymentCost - | PaymentDate - | PaymentCategory - | PaymentPunctual - | PaymentMonthly - - | Clone - | Edit - | Delete - | ConfirmPaymentDelete - - -- Categories - - | Categories - | NoCategories - | CategoryNotDeleted - | AddCategory - | CloneCategory - | EditCategory - | ConfirmCategoryDelete - | CategoryName - | CategoryColor - | Color - | UsedCategory - - -- Statistics - - | Statistics - | ByMonthsAndMean - | By - | Total - - -- Income - - | CumulativeIncomesSince - | NoIncome - | Income - | MonthlyNetIncomes - | AddIncome - | CloneIncome - | EditIncome - | IncomeNotDeleted - | IncomeAmount - | IncomeDate - | ConfirmIncomeDelete - | Add - - -- Form - - | Empty - | InvalidString - | InvalidDate - | CostMustNotBeNull - | InvalidInt - | InvalidCategory - | InvalidColor - | AlreadyExists - | SmallerIntThan - | GreaterIntThan - - -- Errors - - | CreatePaymentError - | EditPaymentError - | DeletePaymentError - | CreateIncomeError - | EditIncomeError - | DeleteIncomeError - | CreateCategoryError - | EditCategoryError - | DeleteCategoryError - | SignOutError - - -- Dialog - - | Confirm - | Undo - - -- Page not found - - | PageNotFound - - -- Weekly report - - | WeeklyReport - | WeeklyReportEmpty - | PaymentCreated - | PaymentsCreated - | PaymentEdited - | PaymentsEdited - | PaymentDeleted - | PaymentsDeleted - | IncomeCreated - | IncomesCreated - | IncomeEdited - | IncomesEdited - | IncomeDeleted - | IncomesDeleted - | PayedFor - | DidNotPayFor - | IsPayedFrom - | IsNotPayedFrom - - -- Http error - - | BadUrl - | Timeout - | NetworkError - | BadPayload - - deriving (Enum, Bounded, Show) - -instance Json.ToJSON Key where - toJSON = Json.String . T.pack . show diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs deleted file mode 100644 index f515c96..0000000 --- a/src/server/Model/Message/Lang.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Model.Message.Lang - ( Lang(..) - , lang - ) where - -data Lang = - English - | French - -lang :: Lang -lang = French diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs deleted file mode 100644 index d065cf2..0000000 --- a/src/server/Model/Message/Parts.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Parts - ( replaceParts - , getParts - ) where - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T - -import Text.ParserCombinators.Parsec - -import Model.Json.MessagePart - -replaceParts :: [Text] -> Text -> Text -replaceParts values message = - T.concat . map (replacePart values) $ getParts message - -replacePart :: [Text] -> MessagePart -> Text -replacePart _ (Str str) = str -replacePart values (Order n) = - fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values - -getParts :: Text -> [MessagePart] -getParts str = - case parse partsParser "" (T.unpack str) of - Right parts -> parts - Left _ -> [] - -partsParser :: Parser [MessagePart] -partsParser = many partParser - -partParser :: Parser MessagePart -partParser = - (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n)) - <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str)) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs deleted file mode 100644 index 7d26c3f..0000000 --- a/src/server/Model/Message/Translations.hs +++ /dev/null @@ -1,729 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Translations - ( getNonFormattedMessage - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key -import Model.Message.Lang - -getNonFormattedMessage :: Lang -> Key -> Text -getNonFormattedMessage = m - -m :: Lang -> Key -> Text - --- Title - -m l SharedCost = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - --- Sign in - -m l Email = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn = - case l of - English -> "Sign in" - French -> "Connexion" - -m l InvalidEmail = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n'est pas valide." - -m l UnauthorizedSignIn = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n'es pas autorisé à te connecter." - -m l Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SendEmailFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion." - -m l EnterValidEmail = - case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." - -m l SignInUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignInExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignInInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignInMailTitle = - case l of - English -> T.concat ["Sign in to ", m l SharedCost] - French -> T.concat ["Connexion à ", m l SharedCost] - -m l SignInMail = - T.intercalate - "\n" - ( case l of - English -> - [ "Hi {1}," - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "See you soon!" - ] - French -> - [ "Salut {1}," - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "À très vite !" - ] - ) - -m l SignInEmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t'avons envoyé un courriel avec un lien pour te connecter." - --- Date - -m l January = - case l of - English -> "january" - French -> "janvier" - -m l February = - case l of - English -> "february" - French -> "février" - -m l March = - case l of - English -> "march" - French -> "mars" - -m l April = - case l of - English -> "april" - French -> "avril" - -m l May = - case l of - English -> "may" - French -> "mai" - -m l June = - case l of - English -> "june" - French -> "juin" - -m l July = - case l of - English -> "july" - French -> "juillet" - -m l August = - case l of - English -> "august" - French -> "août" - -m l September = - case l of - English -> "september" - French -> "septembre" - -m l October = - case l of - English -> "october" - French -> "octobre" - -m l November = - case l of - English -> "november" - French -> "novembre" - -m l December = - case l of - English -> "december" - French -> "décembre" - -m l ShortDate = - case l of - English -> "{3}-{2}-{1}" - French -> "{1}/{2}/{3}" - -m l ShortMonthAndYear = - case l of - English -> "{2}-{1}" - French -> "{1}/{2}" - -m l LongDate = - case l of - English -> "{2} {1}, {3}" - French -> "{1} {2} {3}" - --- Search - -m l SearchName = - case l of - English -> "Search" - French -> "Recherche" - -m l SearchPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l SearchMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - --- Payments - -m l PaymentsAreBalanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Name = - case l of - English -> "Name" - French -> "Nom" - -m l Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payer = - case l of - English -> "Payer" - French -> "Payeur" - -m l Date = - case l of - English -> "Date" - French -> "Date" - -m l Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l AddPayment = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l ClonePayment = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l EditPayment = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l PaymentNotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n'a pas pu être supprimé." - -m l Punctual = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Monthly = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l PaymentsTitle = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment = - case l of - English -> "payment" - French -> "paiement" - -m l Payments = - case l of - English -> "payments" - French -> "paiements" - -m l Worth = - case l of - English -> "{1} worth {2}" - French -> "{1} comptabilisant {2}" - -m l NoPayment = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l PaymentName = - case l of - English -> "Name" - French -> "Nom" - -m l PaymentCost = - case l of - English -> "Cost" - French -> "Coût" - -m l PaymentDate = - case l of - English -> "Date" - French -> "Date" - -m l PaymentCategory = - case l of - English -> "Category" - French -> "Catégorie" - -m l PaymentPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l PaymentMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l ConfirmPaymentDelete = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Edit = - case l of - English -> "Edit" - French -> "Modifier" - -m l Clone = - case l of - English -> "Clone" - French -> "Cloner" - -m l Delete = - case l of - English -> "Delete" - French -> "Supprimer" - --- Categories - -m l Categories = - case l of - English -> "Categories" - French -> "Catégories" - -m l NoCategories = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l CategoryNotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n'a pas pu être supprimé." - -m l AddCategory = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l CloneCategory = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l EditCategory = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l ConfirmCategoryDelete = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l CategoryName = - case l of - English -> "Name" - French -> "Nom" - -m l CategoryColor = - case l of - English -> "Color" - French -> "Couleur" - -m l Color = - case l of - English -> "Color" - French -> "Couleur" - -m l UsedCategory = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - --- Statistics - -m l Statistics = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l ByMonthsAndMean = - case l of - English -> "Payments by category by month months ({1} on average)" - French -> "Paiements par catégorie par mois (en moyenne {1})" - -m l By = - case l of - English -> "{1}: {2}" - French -> "{1} : {2}" - -m l Total = - case l of - English -> "Total" - French -> "Total" - --- Income - -m l CumulativeIncomesSince = - case l of - English -> "Cumulative incomes since {1}" - French -> "Revenus nets cumulés depuis le {1}" - -m l NoIncome = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income = - case l of - English -> "Income" - French -> "Revenu" - -m l MonthlyNetIncomes = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l AddIncome = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l CloneIncome = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l EditIncome = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l IncomeNotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n'a pas pu être supprimé." - -m l IncomeAmount = - case l of - English -> "Amount" - French -> "Montant" - -m l IncomeDate = - case l of - English -> "Date" - French -> "Date" - -m l ConfirmIncomeDelete = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Add = - case l of - English -> "Add" - French -> "Ajouter" - --- Form error - -m l Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l SmallerIntThan = - case l of - English -> "Integer bigger than {1} or equal required" - French -> "Entier supérieur ou égal à {1} requis" - -m l GreaterIntThan = - case l of - English -> "Integer smaller than {1} or equal required" - French -> "Entier inférieur ou égal à {1} requis" - --- Errors - -m l CreatePaymentError = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l EditPaymentError = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l DeletePaymentError = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l CreateIncomeError = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l EditIncomeError = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l DeleteIncomeError = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l CreateCategoryError = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l EditCategoryError = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l DeleteCategoryError = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l SignOutError = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - --- Dialog - -m l Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Undo = - case l of - English -> "Undo" - French -> "Annuler" - --- Page not found - -m l PageNotFound = - case l of - English -> "Page not found" - French -> "Page introuvable" - --- Weekly report - -m l WeeklyReport = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" - -m l WeeklyReportEmpty = - case l of - English -> "No activity the previous week." - French -> "Pas d'activité la semaine passée." - -m l PaymentCreated = - case l of - English -> "{1} payment created:" - French -> "{1} paiement créé :" - -m l PaymentsCreated = - case l of - English -> "{1} payments created:" - French -> "{1} paiements créés :" - -m l PaymentEdited = - case l of - English -> "{1} payment edited:" - French -> "{1} paiement modifié :" - -m l PaymentsEdited = - case l of - English -> "{1} payments edited:" - French -> "{1} paiements modifiés :" - -m l PaymentDeleted = - case l of - English -> "{1} payment deleted:" - French -> "{1} paiement supprimé :" - -m l PaymentsDeleted = - case l of - English -> "{1} payments deleted:" - French -> "{1} paiements supprimés :" - -m l IncomeCreated = - case l of - English -> "{1} income created:" - French -> "{1} revenu créé :" - -m l IncomesCreated = - case l of - English -> "{1} incomes created:" - French -> "{1} revenus créés :" - -m l IncomeEdited = - case l of - English -> "{1} income edited:" - French -> "{1} revenu modifié :" - -m l IncomesEdited = - case l of - English -> "{1} incomes edited:" - French -> "{1} revenus modifiés :" - -m l IncomeDeleted = - case l of - English -> "{1} income deleted:" - French -> "{1} revenu supprimé :" - -m l IncomesDeleted = - case l of - English -> "{1} incomes deleted:" - French -> "{1} revenus supprimés :" - -m l PayedFor = - case l of - English -> "{1} payed {2} for “{3}” at {4}" - French -> "{1} a payé {2} concernant « {3} » le {4}" - -m l DidNotPayFor = - case l of - English -> "{1} didn't pay {2} for “{3}” at {4}" - French -> "{1} n'a pas payé {2} concernant « {3} » le {4}" - -m l IsPayedFrom = - case l of - English -> "{1} is payed {2} of net monthly income from {3}" - French -> "{1} est payé {2} net par mois à partir du {3}" - -m l IsNotPayedFrom = - case l of - English -> "{1} isn't payed {2} of net monthly income from {3}" - French -> "{1} n'est pas payé {2} net par mois à partir du {3}" - --- Http error - -m l BadUrl = - case l of - English -> "URL not valid" - French -> "l'URL n'est pas valide" - -m l Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n'est pas accessible" - -m l BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/src/server/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +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 + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5414d18..5b576c5 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment - ( PaymentId - , Payment(..) + ( Payment(..) , find , list , listMonthly @@ -13,7 +13,6 @@ module Model.Payment , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time (UTCTime) @@ -24,29 +23,19 @@ import Database.SQLite.Simple.ToField (ToField(toField)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Frequency +import Common.Model.Frequency +import Common.Model.Payment (Payment(..)) +import Common.Model.User (UserId) +import Common.Model.Payment (PaymentId) + +import Model.Frequency () import Model.Query (Query(Query)) -import Model.User (UserId) import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type PaymentId = Int64 - -data Payment = Payment - { id :: PaymentId - , userId :: UserId - , name :: Text - , cost :: Int - , date :: Day - , frequency :: Frequency - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Payment where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt instance FromRow Payment where fromRow = Payment <$> @@ -62,12 +51,12 @@ instance FromRow Payment where instance ToRow Payment where toRow p = - [ toField (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (createdAt p) + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) ] find :: PaymentId -> Query (Maybe Payment) @@ -92,13 +81,13 @@ listMonthly = ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create paymentUserId paymentName paymentCost paymentDate paymentFrequency = +create userId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do now <- getCurrentTime SQLite.execute conn "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -112,13 +101,13 @@ createMany payments = ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency = +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute @@ -133,13 +122,13 @@ editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequ ) deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn paymentUserId paymentId = +deleteOwn userId paymentId = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs index 7c504dc..6e1d304 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , list + ( list , listByCategory , save ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Data.Text as T import qualified Database.SQLite.Simple as SQLite -import Model.Category (CategoryId) -import Model.Query (Query(Query)) -import qualified Utils.Text as T - -type PaymentCategoryId = Int64 +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index c8a0d53..eb78a69 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser + ( list + , get , createUser , deleteUser ) where -import Data.Int (Int64) -import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) - -type UserId = Int64 +import Common.Model (UserId, User(..)) -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show +import Model.Query (Query(Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field @@ -37,15 +25,12 @@ instance FromRow User where list :: Query [User] list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -getUser :: Text -> Query (Maybe User) -getUser userEmail = +get :: Text -> Query (Maybe User) +get userEmail = Query (\conn -> listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -findUser :: UserId -> [User] -> Maybe User -findUser userId = find ((==) userId . id) - createUser :: Text -> Text -> Query UserId createUser userEmail userName = Query (\conn -> do diff --git a/src/server/Secure.hs b/src/server/Secure.hs index da48878..f427304 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -11,11 +11,12 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import Model.Message (getMessage) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + import Model.Query (Query) -import Model.User (User) import qualified LoginSession -import qualified Model.Message.Key as Key import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -31,16 +32,16 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.UnauthorizedSignIn + html . fromStrict . Message.get $ Key.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden + html . fromStrict . Message.get $ Key.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.getUser (SignIn.email signIn) + User.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs deleted file mode 100644 index 5ed77e4..0000000 --- a/src/server/Utils/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Utils.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs index 4a247e9..97457c7 100644 --- a/src/server/Utils/Time.hs +++ b/src/server/Utils/Time.hs @@ -2,7 +2,6 @@ module Utils.Time ( belongToCurrentMonth , belongToCurrentWeek , timeToDay - , monthToKey ) where import Data.Time.Clock (UTCTime, getCurrentTime) @@ -10,9 +9,6 @@ import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate (toWeekDate) -import Model.Message.Key (Key) -import qualified Model.Message.Key as K - belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time @@ -27,18 +23,3 @@ belongToCurrentWeek time = do timeToDay :: UTCTime -> IO Day timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time - -monthToKey :: Int -> Maybe Key -monthToKey 1 = Just K.January -monthToKey 2 = Just K.February -monthToKey 3 = Just K.March -monthToKey 4 = Just K.April -monthToKey 5 = Just K.May -monthToKey 6 = Just K.June -monthToKey 7 = Just K.July -monthToKey 8 = Just K.August -monthToKey 9 = Just K.September -monthToKey 10 = Just K.October -monthToKey 11 = Just K.November -monthToKey 12 = Just K.December -monthToKey _ = Nothing diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs deleted file mode 100644 index 354d46a..0000000 --- a/src/server/View/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Format - ( price - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) - -import Conf (Conf) -import qualified Conf - -price :: Conf -> Int -> Text -price conf amount = T.concat [number amount, " ", Conf.currency conf] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index c7d40d8..12c4f34 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,10 +6,11 @@ module View.Mail.SignIn import Data.Text (Text) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.User (User(..)) + import Conf (Conf) -import Model.Message -import Model.Message.Key -import Model.User (User(..)) import qualified Conf as Conf import qualified Model.Mail as M @@ -18,6 +19,6 @@ mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [name user, url] SignInMail + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index 1a80b95..0bafb70 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -9,38 +9,34 @@ import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime) import qualified Data.Map as M import qualified Data.Text as T -import Resource (Status(..), groupByStatus, statuses) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model.User as User +import qualified Common.View.Format as Format -import Model.Income (Income) import Model.Mail (Mail(Mail)) -import Model.Message (getMessage, getParamMessage, plural) -import Model.Payment (Payment) -import Model.User (findUser) -import Model.User (User, UserId) -import qualified Model.Income as Income +import Model.Payment () +import qualified Model.Income () import qualified Model.Mail as M -import qualified Model.Message.Key as K -import qualified Model.Payment as Payment -import qualified Model.User as User - +import Resource (Status(..), groupByStatus, statuses) import Conf (Conf) import qualified Conf as Conf -import qualified View.Format as Format - -import Utils.Time (monthToKey) - mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = Mail { M.from = Conf.noReplyMail conf - , M.to = map User.email users - , M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - getMessage K.WeeklyReportEmpty + Message.get Key.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus = paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = - section - (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn Payment.date $ payments) - where (singleKey, pluralKey) = - case status of - Created -> (K.PaymentCreated, K.PaymentsCreated) - Edited -> (K.PaymentEdited, K.PaymentsEdited) - Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = - getParamMessage - [ formatUserName (Payment.userId payment) users - , Format.price conf . Payment.cost $ payment - , Payment.name payment - , formatDay $ Payment.date payment - ] - ( case status of - Created -> K.PayedFor - Edited -> K.PayedFor - Deleted -> K.DidNotPayFor - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.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] -> [Income] -> Text incomeSection status conf users incomes = - section - (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) - where (singleKey, pluralKey) = - case status of - Created -> (K.IncomeCreated, K.IncomesCreated) - Edited -> (K.IncomeEdited, K.IncomesEdited) - Deleted -> (K.IncomeDeleted, K.IncomesDeleted) + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = - getParamMessage - [ formatUserName (Income.userId income) users - , Format.price conf . Income.amount $ income - , formatDay $ Income.date income - ] - ( case status of - Created -> K.IsPayedFrom - Edited -> K.IsPayedFrom - Deleted -> K.IsNotPayedFrom - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.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 . findUser userId - -formatDay :: Day -> Text -formatDay d = - let (year, month, day) = toGregorian d - in getParamMessage - [ T.pack . show $ day - , fromMaybe "−" . fmap getMessage . monthToKey $ month - , T.pack . show $ year - ] - K.LongDate +formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId section :: Text -> [Text] -> Text section title items = diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 5a2e4f8..1c072a4 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text (renderHtml) -import Design.Global (globalDesign) +import qualified Common.Message as Message +import Common.Model.InitResult (InitResult) +import qualified Common.Message.Key as Key -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) +import Design.Global (globalDesign) -page :: Conf -> InitResult -> Text -page conf initResult = +page :: InitResult -> Text +page initResult = 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 $ getMessage SharedCost) - script ! src "javascripts/client.js" $ "" - jsonScript "translations" getTranslations - jsonScript "conf" conf - jsonScript "result" initResult + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign - body $ do - script ! src "javascripts/main.js" $ "" jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = -- cgit v1.2.3 From 903108a3b64758fa58783878756931e6cf187e53 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 7 Nov 2017 09:43:25 +0100 Subject: Reformat payment queries --- src/server/Model/Payment.hs | 36 +++++++++++++++++++++++++++++++----- src/server/Model/User.hs | 12 ++++++------ 2 files changed, 37 insertions(+), 11 deletions(-) (limited to 'src/server') diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5b576c5..3893850 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -15,6 +15,7 @@ module Model.Payment import Data.Maybe (listToMaybe) import Data.Text (Text) +import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) @@ -76,7 +77,12 @@ listMonthly = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ? ORDER BY name DESC" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) (Only Monthly) ) @@ -86,7 +92,10 @@ create userId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -96,7 +105,10 @@ createMany payments = Query (\conn -> SQLite.executeMany conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) payments ) @@ -112,7 +124,15 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "UPDATE payment SET edited_at = ?, name = ?, cost = ?, date = ?, frequency = ? WHERE id = ?" + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) return True else @@ -147,6 +167,12 @@ modifiedDuring start end = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE (created_at >= ? AND created_at <= ?)" + , " OR (edited_at >= ? AND edited_at <= ?)" + , " OR (deleted_at >= ? AND deleted_at <= ?)" + ]) (start, end, start, end, start, end) ) diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index eb78a69..e14fcef 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -4,8 +4,8 @@ module Model.User ( list , get - , createUser - , deleteUser + , create + , delete ) where import Data.Maybe (listToMaybe) @@ -31,8 +31,8 @@ get userEmail = SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -createUser :: Text -> Text -> Query UserId -createUser userEmail userName = +create :: Text -> Text -> Query UserId +create userEmail userName = Query (\conn -> do now <- getCurrentTime SQLite.execute @@ -42,8 +42,8 @@ createUser userEmail userName = SQLite.lastInsertRowId conn ) -deleteUser :: Text -> Query () -deleteUser userEmail = +delete :: Text -> Query () +delete userEmail = Query (\conn -> SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) ) -- cgit v1.2.3 From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- src/server/Common | 1 - src/server/Conf.hs | 39 -- src/server/Controller/Category.hs | 55 --- src/server/Controller/Income.hs | 48 --- src/server/Controller/Index.hs | 86 ---- src/server/Controller/Payment.hs | 60 --- src/server/Controller/SignIn.hs | 47 --- src/server/Cookie.hs | 56 --- src/server/Design/Color.hs | 35 -- src/server/Design/Constants.hs | 27 -- src/server/Design/Dialog.hs | 24 -- src/server/Design/Errors.hs | 55 --- src/server/Design/Form.hs | 130 ------ src/server/Design/Global.hs | 75 ---- src/server/Design/Helper.hs | 90 ----- src/server/Design/Media.hs | 36 -- src/server/Design/Tooltip.hs | 16 - src/server/Design/View/Header.hs | 78 ---- src/server/Design/View/Payment.hs | 17 - src/server/Design/View/Payment/Header.hs | 84 ---- src/server/Design/View/Payment/Pages.hs | 54 --- src/server/Design/View/Payment/Table.hs | 42 -- src/server/Design/View/SignIn.hs | 42 -- src/server/Design/View/Stat.hs | 15 - src/server/Design/View/Table.hs | 84 ---- src/server/Design/Views.hs | 49 --- src/server/Job/Daemon.hs | 36 -- src/server/Job/Frequency.hs | 13 - src/server/Job/Kind.hs | 22 - src/server/Job/Model.hs | 47 --- src/server/Job/MonthlyPayment.hs | 26 -- src/server/Job/WeeklyReport.hs | 28 -- src/server/Json.hs | 19 - src/server/LoginSession.hs | 53 --- src/server/Main.hs | 79 ---- src/server/MimeMail.hs | 672 ------------------------------- src/server/Model/Category.hs | 79 ---- src/server/Model/Frequency.hs | 22 - src/server/Model/Income.hs | 97 ----- src/server/Model/Init.hs | 27 -- src/server/Model/Mail.hs | 12 - src/server/Model/Payer.hs | 216 ---------- src/server/Model/Payment.hs | 178 -------- src/server/Model/PaymentCategory.hs | 62 --- src/server/Model/Query.hs | 32 -- src/server/Model/SignIn.hs | 66 --- src/server/Model/UUID.hs | 10 - src/server/Model/User.hs | 49 --- src/server/Resource.hs | 54 --- src/server/Secure.hs | 47 --- src/server/SendMail.hs | 44 -- src/server/Utils/Time.hs | 25 -- src/server/Validation.hs | 23 -- src/server/View/Mail/SignIn.hs | 24 -- src/server/View/Mail/WeeklyReport.hs | 102 ----- src/server/View/Page.hs | 43 -- 56 files changed, 3552 deletions(-) delete mode 120000 src/server/Common delete mode 100644 src/server/Conf.hs delete mode 100644 src/server/Controller/Category.hs delete mode 100644 src/server/Controller/Income.hs delete mode 100644 src/server/Controller/Index.hs delete mode 100644 src/server/Controller/Payment.hs delete mode 100644 src/server/Controller/SignIn.hs delete mode 100644 src/server/Cookie.hs delete mode 100644 src/server/Design/Color.hs delete mode 100644 src/server/Design/Constants.hs delete mode 100644 src/server/Design/Dialog.hs delete mode 100644 src/server/Design/Errors.hs delete mode 100644 src/server/Design/Form.hs delete mode 100644 src/server/Design/Global.hs delete mode 100644 src/server/Design/Helper.hs delete mode 100644 src/server/Design/Media.hs delete mode 100644 src/server/Design/Tooltip.hs delete mode 100644 src/server/Design/View/Header.hs delete mode 100644 src/server/Design/View/Payment.hs delete mode 100644 src/server/Design/View/Payment/Header.hs delete mode 100644 src/server/Design/View/Payment/Pages.hs delete mode 100644 src/server/Design/View/Payment/Table.hs delete mode 100644 src/server/Design/View/SignIn.hs delete mode 100644 src/server/Design/View/Stat.hs delete mode 100644 src/server/Design/View/Table.hs delete mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Job/Daemon.hs delete mode 100644 src/server/Job/Frequency.hs delete mode 100644 src/server/Job/Kind.hs delete mode 100644 src/server/Job/Model.hs delete mode 100644 src/server/Job/MonthlyPayment.hs delete mode 100644 src/server/Job/WeeklyReport.hs delete mode 100644 src/server/Json.hs delete mode 100644 src/server/LoginSession.hs delete mode 100644 src/server/Main.hs delete mode 100644 src/server/MimeMail.hs delete mode 100644 src/server/Model/Category.hs delete mode 100644 src/server/Model/Frequency.hs delete mode 100644 src/server/Model/Income.hs delete mode 100644 src/server/Model/Init.hs delete mode 100644 src/server/Model/Mail.hs delete mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Model/Payment.hs delete mode 100644 src/server/Model/PaymentCategory.hs delete mode 100644 src/server/Model/Query.hs delete mode 100644 src/server/Model/SignIn.hs delete mode 100644 src/server/Model/UUID.hs delete mode 100644 src/server/Model/User.hs delete mode 100644 src/server/Resource.hs delete mode 100644 src/server/Secure.hs delete mode 100644 src/server/SendMail.hs delete mode 100644 src/server/Utils/Time.hs delete mode 100644 src/server/Validation.hs delete mode 100644 src/server/View/Mail/SignIn.hs delete mode 100644 src/server/View/Mail/WeeklyReport.hs delete mode 100644 src/server/View/Page.hs (limited to 'src/server') diff --git a/src/server/Common b/src/server/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/server/Common +++ /dev/null @@ -1 +0,0 @@ -../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs deleted file mode 100644 index 92df4e9..0000000 --- a/src/server/Conf.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Conf - ( get - , Conf(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) - -import Common.Model.Currency (Currency(..)) - -data Conf = Conf - { hostname :: Text - , port :: Int - , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: 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 - ) - case conf of - Left msg -> error (T.unpack msg) - Right c -> return c diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs deleted file mode 100644 index 1a44083..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Category - ( create - , edit - , delete - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) - -import Common.Model.Category (CategoryId) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.CreateCategory as Json -import qualified Common.Model.EditCategory as Json - -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -create :: Json.CreateCategory -> ActionM () -create (Json.CreateCategory name color) = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Category.create name color) >>= jsonId - ) - -edit :: Json.EditCategory -> ActionM () -edit (Json.EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color - if updated - then status ok200 - else status badRequest400 - ) - -delete :: CategoryId -> ActionM () -delete categoryId = - Secure.loggedAction (\_ -> do - deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId - if null paymentCategories - then Category.delete categoryId - else return False - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 148b713..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Income - ( create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) - -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query -import qualified Secure - -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId - ) - -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 8473c5c..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Controller.Index - ( get - , signOut - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) - -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) - -import Conf (Conf(..)) -import Model.Init (getInit) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) - -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of - Nothing -> - return . Left $ Key.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Key.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Key.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized - Just user -> Right user - -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of - Nothing -> - return Nothing - Just token -> do - liftIO . Query.run . getUserFromToken $ token - -signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs deleted file mode 100644 index 6a9ede7..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Payment - ( list - , create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import qualified Common.Model.CreatePayment as M -import qualified Common.Model.EditPayment as M -import Common.Model (PaymentId, User(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json - ) - -create :: M.CreatePayment -> ActionM () -create (M.CreatePayment name cost date category frequency) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId - ) - -editOwn :: M.EditPayment -> ActionM () -editOwn (M.EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategory.save name category >> return () - else return () - return edited - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId - if deleted - then status ok200 - else status badRequest400 - ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs deleted file mode 100644 index 932ce53..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.SignIn as M - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> M.SignIn -> ActionM () -signIn conf (M.SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs deleted file mode 100644 index 96d45da..0000000 --- a/src/server/Cookie.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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.Scotty.Trans -import Web.Cookie - -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/src/server/Design/Color.hs b/src/server/Design/Color.hs deleted file mode 100644 index 06c468e..0000000 --- a/src/server/Design/Color.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.Color where - -import qualified Clay.Color as C - --- 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 diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs deleted file mode 100644 index 4e2b8cc..0000000 --- a/src/server/Design/Constants.hs +++ /dev/null @@ -1,27 +0,0 @@ -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/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs deleted file mode 100644 index 4678633..0000000 --- a/src/server/Design/Dialog.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/src/server/Design/Errors.hs b/src/server/Design/Errors.hs deleted file mode 100644 index 57aaeee..0000000 --- a/src/server/Design/Errors.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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/src/server/Design/Form.hs b/src/server/Design/Form.hs deleted file mode 100644 index ebb8ac8..0000000 --- a/src/server/Design/Form.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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 - let inputZIndex = 1 - - label ? do - cursor pointer - color Color.silver - - ".textInput" ? do - position relative - marginBottom (em 1.5) - paddingTop (px inputTop) - marginTop (px (-10)) - - input ? do - width (pct 100) - position relative - zIndex inputZIndex - backgroundColor transparent - paddingBottom (px inputPaddingBottom) - 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 - lineHeight (px inputHeight) - position absolute - top (px inputTop) - left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) - - button ? do - position absolute - right (px 0) - top (px 27) - zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" - - (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 - - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - - ".selectInput" ? do - label ? do - display block - marginBottom (px 10) - fontSize (pct 80) - select ? do - backgroundColor Color.white - border solid (px 1) Color.silver - sym borderRadius (px 3) - sym2 padding (px 5) (px 8) - option ? do - firstChild & display none - sym2 padding (px 5) (px 8) - ".error" & do - select ? borderColor Color.chestnutRose - ".errorMessage" ? do - color Color.chestnutRose - fontSize (pct 80) - marginTop (em 0.5) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs deleted file mode 100644 index 47ea4a9..0000000 --- a/src/server/Design/Global.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Global - ( globalDesign - ) where - -import Clay - -import Data.Text.Lazy (Text) - -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -globalDesign :: Text -globalDesign = renderWith compact [] global - -global :: Css -global = do - ".errors" ? Errors.design - ".dialog" ? Dialog.design - ".tooltip" ? Tooltip.design - Views.design - Form.design - - body ? do - minWidth (px 320) - 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) - - a ? cursor pointer - - input ? fontSize inherit - - h1 ? do - color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) - - Media.desktop $ fontSize (px 24) - Media.tablet $ fontSize (px 22) - Media.mobile $ fontSize (px 20) - - ul ? do - "margin-bottom" -: "3vh" - "margin-left" -: "1vh" - li 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) - waitable - -waitable :: Css -waitable = do - svg # ".loader" ? display none - ".waiting" & do - ".content" ? do - display flex - fontSize (px 0) - opacity 0 - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation - -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - -centeredWithMargin :: Css -centeredWithMargin = do - width (pct blockPercentWidth) - marginLeft auto - marginRight auto - -verticalCentering :: Css -verticalCentering = do - position absolute - top (pct 50) - "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs deleted file mode 100644 index 77220ee..0000000 --- a/src/server/Design/Media.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Design.Media - ( mobile - , mobileTablet - , tablet - , tabletDesktop - , desktop - ) where - -import Clay hiding (query) -import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media - -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/src/server/Design/Tooltip.hs b/src/server/Design/Tooltip.hs deleted file mode 100644 index 1da8764..0000000 --- a/src/server/Design/Tooltip.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs deleted file mode 100644 index 20627e6..0000000 --- a/src/server/Design/View/Header.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Helper as Helper -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 - height (pct 100) - 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 - Helper.waitable - heightMedia - 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/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs deleted file mode 100644 index d3c7650..0000000 --- a/src/server/Design/View/Payment.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment - ( design - ) where - -import Clay - -import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs deleted file mode 100644 index f02da8a..0000000 --- a/src/server/Design/View/Payment/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".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) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? 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/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs deleted file mode 100644 index ade81a8..0000000 --- a/src/server/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - 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) - - ".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/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs deleted file mode 100644 index a866b40..0000000 --- a/src/server/Design/View/Payment/Table.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - 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) - - ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) - width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs deleted file mode 100644 index 214e663..0000000 --- a/src/server/Design/View/SignIn.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.SignIn - ( design - ) where - -import Clay -import Data.Monoid ((<>)) - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? 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/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs deleted file mode 100644 index 0a5b258..0000000 --- a/src/server/Design/View/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs deleted file mode 100644 index 95abf90..0000000 --- a/src/server/Design/View/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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) - - ".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 - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - 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/src/server/Design/Views.hs b/src/server/Design/Views.hs deleted file mode 100644 index bc6ac83..0000000 --- a/src/server/Design/Views.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Views - ( design - ) where - -import Clay - -import qualified Design.View.Header as Header -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 - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - header ? Header.design - ".payment" ? Payment.design - ".signIn" ? SignIn.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs deleted file mode 100644 index 0bc6f6e..0000000 --- a/src/server/Job/Daemon.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Job.Daemon - ( runDaemons - ) where - -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) - -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.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/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs deleted file mode 100644 index 263f6e6..0000000 --- a/src/server/Job/Frequency.hs +++ /dev/null @@ -1,13 +0,0 @@ -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/src/server/Job/Kind.hs b/src/server/Job/Kind.hs deleted file mode 100644 index af5d4f8..0000000 --- a/src/server/Job/Kind.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Job.Kind - ( Kind(..) - ) where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -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/src/server/Job/Model.hs b/src/server/Job/Model.hs deleted file mode 100644 index e1a3c77..0000000 --- a/src/server/Job/Model.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Job.Model - ( Job(..) - , getLastExecution - , actualizeLastExecution - , actualizeLastCheck - ) where - -import Data.Maybe (isJust) -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 - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time - ) - -actualizeLastExecution :: Kind -> UTCTime -> Query () -actualizeLastExecution jobKind time = - Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result - 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/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs deleted file mode 100644 index ba24cca..0000000 --- a/src/server/Job/MonthlyPayment.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Job.MonthlyPayment - ( monthlyPayment - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Common.Model (Frequency(..), Payment(..)) - -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query - -monthlyPayment :: Maybe UTCTime -> IO UTCTime -monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly - now <- getCurrentTime - actualDay <- timeToDay now - let punctualPayments = map - (\p -> p - { _payment_frequency = Punctual - , _payment_date = actualDay - , _payment_createdAt = now - }) - monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) - return now diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs deleted file mode 100644 index 5737c75..0000000 --- a/src/server/Job/WeeklyReport.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Job.WeeklyReport - ( weeklyReport - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User -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 - (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) - return () - return now diff --git a/src/server/Json.hs b/src/server/Json.hs deleted file mode 100644 index cc6327a..0000000 --- a/src/server/Json.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} - -module Json - ( jsonObject - , jsonId - ) where - -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs deleted file mode 100644 index 6f6d620..0000000 --- a/src/server/LoginSession.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LoginSession - ( put - , get - , delete - ) where - -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS - -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/src/server/Main.hs b/src/server/Main.hs deleted file mode 100644 index db73474..0000000 --- a/src/server/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import Network.Wai.Middleware.Static -import qualified Data.Text.Lazy as LT -import Web.Scotty - -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.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query - -main :: IO () -main = do - conf <- Conf.get "application.conf" - _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware . staticPolicy $ noDots >-> addBase "public" - - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments - text . LT.pack . show $ exceedingPayers - - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken - - post "/signIn" $ do - jsonData >>= SignIn.signIn conf - - post "/signOut" $ - Index.signOut conf - - post "/payment" $ - jsonData >>= Payment.create - - put "/payment" $ - jsonData >>= Payment.editOwn - - delete "/payment" $ do - paymentId <- param "id" - Payment.deleteOwn paymentId - - post "/income" $ - jsonData >>= Income.create - - put "/income" $ - jsonData >>= Income.editOwn - - delete "/income" $ do - incomeId <- param "id" - Income.deleteOwn incomeId - - post "/category" $ - jsonData >>= Category.create - - put "/category" $ - jsonData >>= Category.edit - - delete "/category" $ do - categoryId <- param "id" - Category.delete categoryId - -mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) -mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/src/server/MimeMail.hs b/src/server/MimeMail.hs deleted file mode 100644 index 0faaf98..0000000 --- a/src/server/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs deleted file mode 100644 index 6b7a488..0000000 --- a/src/server/Model/Category.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (Category(..), CategoryId) - -import Model.Query (Query(Query)) - -instance FromRow Category where - fromRow = Category <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Category] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs deleted file mode 100644 index 4f7b83d..0000000 --- a/src/server/Model/Frequency.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -import Common.Model.Frequency (Frequency) - -instance FromField Frequency where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs deleted file mode 100644 index bbe7657..0000000 --- a/src/server/Model/Income.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (Income(..), IncomeId, User(..), UserId) - -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Income where - resourceCreatedAt = _income_createdAt - resourceEditedAt = _income_editedAt - resourceDeletedAt = _income_deletedAt - -instance FromRow Income where - fromRow = Income <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Income] -list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Income] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs deleted file mode 100644 index 8c6a961..0000000 --- a/src/server/Model/Init.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Init - ( getInit - ) where - -import Common.Model (Init(Init), User(..)) - -import Conf (Conf) -import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.User as User - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - User.list <*> - (return . _user_id $ user) <*> - Payment.list <*> - Income.list <*> - Category.list <*> - PaymentCategory.list <*> - (return . Conf.currency $ conf) diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs deleted file mode 100644 index 9a4db73..0000000 --- a/src/server/Model/Mail.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Model.Mail - ( Mail(..) - ) where - -import Data.Text (Text) - -data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text - , plainBody :: Text - } deriving (Eq, Show) diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs deleted file mode 100644 index de4abd1..0000000 --- a/src/server/Model/Payer.hs +++ /dev/null @@ -1,216 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time - -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -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 - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs deleted file mode 100644 index 3893850..0000000 --- a/src/server/Model/Payment.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , list - , listMonthly - , create - , createMany - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model.Frequency -import Common.Model.Payment (Payment(..)) -import Common.Model.User (UserId) -import Common.Model.Payment (PaymentId) - -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_payment_frequency p) - , toField (_payment_createdAt p) - ] - -find :: PaymentId -> Query (Maybe Payment) -find paymentId = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - ) - -list :: Query [Payment] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" - ) - -listMonthly :: Query [Payment] -listMonthly = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" - , "ORDER BY name DESC" - ]) - (Only Monthly) - ) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE (created_at >= ? AND created_at <= ?)" - , " OR (edited_at >= ? AND edited_at <= ?)" - , " OR (deleted_at >= ? AND deleted_at <= ?)" - ]) - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs deleted file mode 100644 index 6e1d304..0000000 --- a/src/server/Model/PaymentCategory.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T - -import Model.Query (Query(Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower diff --git a/src/server/Model/Query.hs b/src/server/Model/Query.hs deleted file mode 100644 index d15fb5f..0000000 --- a/src/server/Model/Query.hs +++ /dev/null @@ -1,32 +0,0 @@ -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/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs deleted file mode 100644 index c5182f0..0000000 --- a/src/server/Model/SignIn.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.SignIn - ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid - ) where - -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 - -data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool - } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs deleted file mode 100644 index 6cb7ce0..0000000 --- a/src/server/Model/UUID.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Model.UUID - ( generateUUID - ) where - -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) - -generateUUID :: IO Text -generateUUID = pack . toString <$> nextRandom diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs deleted file mode 100644 index e14fcef..0000000 --- a/src/server/Model/User.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.User - ( list - , get - , create - , delete - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (UserId, User(..)) - -import Model.Query (Query(Query)) - -instance FromRow User where - fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field - -list :: Query [User] -list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") - -get :: Text -> Query (Maybe User) -get userEmail = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) - ) - -create :: Text -> Text -> Query UserId -create userEmail userName = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -delete :: Text -> Query () -delete userEmail = - Query (\conn -> - SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) - ) diff --git a/src/server/Resource.hs b/src/server/Resource.hs deleted file mode 100644 index f52bbfa..0000000 --- a/src/server/Resource.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Resource - ( Resource - , resourceCreatedAt - , resourceEditedAt - , resourceDeletedAt - , Status(..) - , statuses - , groupByStatus - , statusDuring - ) where - -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -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/src/server/Secure.hs b/src/server/Secure.hs deleted file mode 100644 index f427304..0000000 --- a/src/server/Secure.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Secure - ( loggedAction - , getUserFromToken - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) - -import Model.Query (Query) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User - -loggedAction :: (User -> ActionM ()) -> ActionM () -loggedAction action = do - maybeToken <- LoginSession.get - case maybeToken of - Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token - case maybeUser of - Just user -> - action user - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - User.get (SignIn.email signIn) - Nothing -> - return Nothing diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs deleted file mode 100644 index f7ba3fd..0000000 --- a/src/server/SendMail.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SendMail - ( sendMail - ) where - -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) - -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M - -import Model.Mail (Mail(Mail)) - -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = 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 putStrLn "OK" - return result - -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/src/server/Utils/Time.hs b/src/server/Utils/Time.hs deleted file mode 100644 index 97457c7..0000000 --- a/src/server/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/src/server/Validation.hs b/src/server/Validation.hs deleted file mode 100644 index 1f332c9..0000000 --- a/src/server/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs deleted file mode 100644 index 12c4f34..0000000 --- a/src/server/View/Mail/SignIn.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.User (User(..)) - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) - } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs deleted file mode 100644 index 0bafb70..0000000 --- a/src/server/View/Mail/WeeklyReport.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.WeeklyReport - ( mail - ) where - -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model.User as User -import qualified Common.View.Format as Format - -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf - -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = - Mail - { M.from = Conf.noReplyMail conf - , M.to = map _user_email users - , M.subject = T.concat - [ Message.get Key.App_Title - , " − " - , Message.get Key.WeeklyReport_Title - ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) - } - -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = - if M.null paymentsByStatus && M.null incomesByStatus - then - Message.get Key.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] -> [Payment] -> Text -paymentSection status conf users payments = - section sectionTitle sectionItems - where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments - -payedFor :: Status -> Conf -> [User] -> Payment -> Text -payedFor status conf users payment = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.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] -> [Income] -> Text -incomeSection status conf users incomes = - section sectionTitle sectionItems - where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes - -isPayedFrom :: Status -> Conf -> [User] -> Income -> Text -isPayedFrom status conf users income = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.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 . User.find userId - -section :: Text -> [Text] -> Text -section title items = - T.concat - [ title - , "\n\n" - , T.unlines . map (" - " <>) $ items - ] diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs deleted file mode 100644 index 1c072a4..0000000 --- a/src/server/View/Page.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Page - ( page - ) where - -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json - -import Text.Blaze.Html -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 Text.Blaze.Html.Renderer.Text (renderHtml) - -import qualified Common.Message as Message -import Common.Model.InitResult (InitResult) -import qualified Common.Message.Key as Key - -import Design.Global (globalDesign) - -page :: InitResult -> Text -page initResult = - 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 $ Message.get Key.App_Title) - script ! src "javascript/main.js" $ "" - jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" - H.style $ toHtml globalDesign - -jsonScript :: Json.ToJSON a => Text -> a -> Html -jsonScript scriptId json = - script - ! A.id (toValue scriptId) - ! type_ "application/json" - $ toHtml . decodeUtf8 . encode $ json -- cgit v1.2.3