diff options
Diffstat (limited to 'src/server')
78 files changed, 0 insertions, 4843 deletions
diff --git a/src/server/Conf.hs b/src/server/Conf.hs deleted file mode 100644 index a05349d..0000000 --- a/src/server/Conf.hs +++ /dev/null @@ -1,37 +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) - -data Conf = Conf - { hostname :: Text - , port :: Int - , signInExpiration :: NominalDiffTime - , currency :: Text - , 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 <*> - 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 3f800da..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,53 +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 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 - -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.pack . show $ Key.CategoryNotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 18394d0..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,49 +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 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) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId - ) - -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.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.pack . show $ Key.IncomeNotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 9fb2aa0..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,84 +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 Web.Scotty hiding (get) - -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 -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 . InitError $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return InitEmpty - Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) 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 $ SignInInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ SignInUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ SignInExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left UnauthorizedSignIn - 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 d71b451..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,61 +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 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 - ) - -create :: Json.CreatePayment -> ActionM () -create (Json.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 :: Json.EditPayment -> ActionM () -editOwn (Json.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 152168c..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( 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 Conf (Conf) -import Model.Message.Key -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 -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) - then do - maybeUser <- liftIO . Query.run $ User.getUser login - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login - 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] - 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 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/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 afc601f..0000000 --- a/src/server/Design/Color.hs +++ /dev/null @@ -1,32 +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 - -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 e742978..0000000 --- a/src/server/Design/Global.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Global - ( globalDesign - ) where - -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.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 - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design - ".errors" ? Errors.design - ".dialog" ? Dialog.design - ".tooltip" ? Tooltip.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 - - 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 <? do - "margin-bottom" -: "2vh" - before & do - content (stringContent "• ") - color Color.chestnutRose - "margin-right" -: "0.3vw" - ul <? do - "margin-left" -: "3vh" - "margin-top" -: "2vh" - - ".dialog" ? ".content" ? button ? do - ".confirm" & Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten - - svg ? height (pct 100) 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 deleted file mode 100644 index 869616d..0000000 --- a/src/server/Design/Helper.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Helper - ( clearFix - , button - , input - , iconButton - , centeredWithMargin - , verticalCentering - ) where - -import Prelude hiding (span) - -import Clay hiding (button, input) - -import Data.Monoid ((<>)) - -import Design.Constants -import Design.Color as Color - -clearFix :: Css -clearFix = - after & do - content (stringContent "") - display displayTable - clear both - -button :: Color -> Color -> Size a -> (Color -> Color) -> Css -button backgroundCol textCol h focusOp = do - 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) - -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) - -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%)" 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/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/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/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/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 8c11ccf..0000000 --- a/src/server/Job/MonthlyPayment.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Job.MonthlyPayment - ( monthlyPayment - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Model.Frequency -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 17c2594..0000000 --- a/src/server/Main.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -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 - -main :: IO () -main = do - conf <- Conf.get "application.conf" - _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware . staticPolicy $ noDots >-> addBase "public" - - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken - - post "/signIn" $ do - email <- param "email" - SignIn.signIn conf email - - 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 9597bd9..0000000 --- a/src/server/Model/Category.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Category - ( CategoryId - , Category(..) - , 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 Model.Query (Query(Query)) - -type CategoryId = Int64 - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - -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 f9958e1..0000000 --- a/src/server/Model/Frequency.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Model.Frequency - ( 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 - -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 c6cdb55..0000000 --- a/src/server/Model/Income.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Income - ( IncomeId - , Income(..) - , 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) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -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 - -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 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 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 7a9ccea..0000000 --- a/src/server/Model/Init.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Init - ( getInit - ) where - -import Model.Json.Init (Init) -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) 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/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/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/Payment.hs b/src/server/Model/Payment.hs deleted file mode 100644 index 5414d18..0000000 --- a/src/server/Model/Payment.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Payment - ( PaymentId - , Payment(..) - , find - , list - , listMonthly - , create - , createMany - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -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 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 - -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 (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (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 - "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 paymentUserId 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) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId 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 - then do - now <- getCurrentTime - SQLite.execute - conn - "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 paymentUserId 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 - 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 - "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 7c504dc..0000000 --- a/src/server/Model/PaymentCategory.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , 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 - -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show - -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 c8a0d53..0000000 --- a/src/server/Model/User.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser - , 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 - -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show - -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") - -getUser :: Text -> Query (Maybe User) -getUser 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 - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -deleteUser :: Text -> Query () -deleteUser 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 da48878..0000000 --- a/src/server/Secure.hs +++ /dev/null @@ -1,46 +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 Model.Message (getMessage) -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 - -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 . getMessage $ Key.UnauthorizedSignIn - Nothing -> do - status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - User.getUser (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/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 deleted file mode 100644 index 4a247e9..0000000 --- a/src/server/Utils/Time.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - , monthToKey - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) -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 - (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 - -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/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/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 deleted file mode 100644 index c7d40d8..0000000 --- a/src/server/View/Mail/SignIn.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -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 - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -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 - } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs deleted file mode 100644 index 1a80b95..0000000 --- a/src/server/View/Mail/WeeklyReport.hs +++ /dev/null @@ -1,126 +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.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 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 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 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.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 - getMessage K.WeeklyReportEmpty - 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 - (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) - -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 - ) - -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) - -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 - ) - -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 - -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 5a2e4f8..0000000 --- a/src/server/View/Page.hs +++ /dev/null @@ -1,48 +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 Design.Global (globalDesign) - -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) - -page :: Conf -> InitResult -> Text -page conf 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 - 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 = - script - ! A.id (toValue scriptId) - ! type_ "application/json" - $ toHtml . decodeUtf8 . encode $ json |