diff options
324 files changed, 11074 insertions, 8851 deletions
@@ -1,8 +1,11 @@ database database-shm database-wal -elm-stuff/ -.stack-work -public/javascripts/client.js -sessionKey +dist-server +dist-client local.conf +public/javascript/main.js +result-client +result-server +sessionKey +.ghc.environment.* diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..82305b9 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,34 @@ +steps: + - simple_align: + cases: true + top_level_patterns: true + records: true + + - imports: + align: global + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: true + space_surround: false + + - language_pragmas: + style: vertical + align: true + remove_redundant: true + + - trailing_whitespace: {} + +columns: 80 + +newline: native + +language_extensions: + - ExistentialQuantification + - LambdaCase + - MultiParamTypeClasses + - OverloadedStrings + - RecursiveDo + - ScopedTypeVariables diff --git a/.tmuxinator.yml b/.tmuxinator.yml index d8b97c5..2a765c0 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -1,11 +1,14 @@ name: sharedCost +startup_window: app windows: - - main: - layout: 3747,239x59,0,0{144x59,0,0,0,94x59,145,0[94x30,145,0,1,94x28,145,31,2]} + - console: + - clear + - app: panes: - - # Empty - - make install-client watch-client - - make install-server watch-server + - server: + - make watch-server + - client: + - make watch-client - db: - sqlite3 database @@ -1,45 +1,62 @@ start: - @nix-shell --command "mux local" + @nix-shell tools.nix --command "tmuxinator local" stop: @tmux kill-session -t sharedCost -dist: - @nix-shell --command "make clean install build" - clean: clean-server clean-client -install: install-server install-client -build: build-server build-client -# Server +build: build-server build-client cp-client + +# Client # ------ -clean-server: - @stack clean > /dev/null +clean-client: + @rm -rf dist-client -install-server: - @stack setup +build-client: + @nix-shell -A shells.ghcjs --run "make build-client-inside" -build-server: - @stack build || : +build-client-inside: + @cabal --project-file=cabal-client.project --builddir=dist-client new-build all -launch-server: - @(killall sharedCost || :) && stack exec sharedCost +cp-client: + @cp dist-client/build/x86_64-linux/ghcjs-*/client-*/*/client/build/client/client.jsexe/all.js public/javascript/main.js -watch-server: - @nodemon -e hs,conf --exec 'clear && make build-server --silent && make launch-server' +watch-client: + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(tput reset && make build-client-inside && make cp-client) || true'" -# Client +# Server # ------ -clean-client: - @rm -r elm-stuff >/dev/null 2>&1 || true +clean-server: + @rm -rf dist-server -install-client: - @elm package install --yes +build-server: + @nix-shell -A shells.ghc --run "make build-server-inside" -build-client: - @elm make src/client/Main.elm --output public/javascripts/client.js || true +build-server-inside: + @cabal --project-file=cabal-server.project --builddir=dist-server new-build all -watch-client: - @nodemon -e elm --exec 'clear && make build-client --silent' +run-server: + @(fuser -k 3000/tcp &>/dev/null) || : + @./dist-server/build/x86_64-linux/ghc-*/server-0.0.1/*/server/build/server/server + +watch-server: + @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(tput reset && make build-server-inside && make run-server) || :'" + +# Deploy +# ------ + +deploy: + @make clean + @nix-build -o result-server -A ghc.server + @nix-build -o result-client -A ghcjs.client + @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' + @rm -rf bundle + @mkdir bundle + @cp application.conf bundle + @cp -r public bundle + @cp result-server/bin/server bundle + @rsync -avzhr bundle/ guyonvarch.me:servers/shared-cost + @rm -rf bundle @@ -1,5 +1,4 @@ -Shared Cost -=========== +# Shared Cost Share costs with a group of people: @@ -8,8 +7,7 @@ Share costs with a group of people: - Statistics by month, - Weekly activity sent by email. -Getting started ---------------- +## Getting started Install nix: @@ -19,51 +17,43 @@ curl https://nixos.org/nix/install | sh Start the environment with: -``` sh +```bash ./make start ``` +Init the database with migration scripts: + +```bash +sqlite3 database < server/migrations/1.sql +sqlite3 database < server/migrations/2.sql +sqlite3 database < server/migrations/3.sql +``` + Inside the tmux session, add some users with sqlite after the migration is done: ``` sqlite3 database -insert into user(creation, email, name) values (datetime('now'), 'john@mail.com', 'John'); -insert into user(creation, email, name) values (datetime('now'), 'lisa@mail.com', 'Lisa'); +insert into user(creation, email, name, password) values (datetime('now'), 'john@mail.com', 'John', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.'); +insert into user(creation, email, name, password) values (datetime('now'), 'lisa@mail.com', 'Lisa', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.'); ``` Later, stop the environment with: -```sh +```bash ./make stop ``` -Dist ----- +## Deploy -``` -make dist +```bash +make deploy ``` -Configuration -------------- +## Configuration See [application.conf](application.conf). -TODO ----- - -### Chart - -- Tooltip with values -- Show / Hide serie by clicking on caption -- Adapt to screen width -- Show only the last entries and allow to move in time ? - -### Other +## Documentation -- Add payment balance in weekly report -- search by payment category and payment date -- Move up element ids security (editOwn is actually at db level) -- Prevent a daemon to freeze when it got “SQLite3 returned ErrorBusy while attempting to perform step.” -- Minify javascript from elm for production build -- CRUD animations (loading, created-updated-deleted element) +- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.4/docs/doc-index-All.html) +- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-core-0.5/docs/doc-index-All.html) diff --git a/application.conf b/application.conf index 49b81a7..021fa2a 100644 --- a/application.conf +++ b/application.conf @@ -4,5 +4,6 @@ currency = "€" signInExpiration = 5 minutes noReplyMail = "no-reply@mail.com" https = False +devMode = True importMaybe "local.conf" diff --git a/cabal-client.project b/cabal-client.project new file mode 100644 index 0000000..182ead2 --- /dev/null +++ b/cabal-client.project @@ -0,0 +1,4 @@ +compiler: ghcjs +packages: + common/ + client/ diff --git a/cabal-server.project b/cabal-server.project new file mode 100644 index 0000000..0ce5568 --- /dev/null +++ b/cabal-server.project @@ -0,0 +1,3 @@ +packages: + common/ + server/ diff --git a/client/Setup.hs b/client/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/client/client.cabal b/client/client.cabal new file mode 100644 index 0000000..cf2c5a1 --- /dev/null +++ b/client/client.cabal @@ -0,0 +1,90 @@ +Name: client +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 + +Executable client + Main-Is: Main.hs + -- Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + + Default-extensions: + ExistentialQuantification + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RecursiveDo + ScopedTypeVariables + + Build-depends: + aeson + , base >= 4.11 && < 5 + , bytestring + , common + , containers + , data-default + , ghcjs-dom-jsffi + , jsaddle-dom + , reflex-dom + , text + , time + , validation + + -- Router + , ghcjs-base + , ghcjs-prim + , ghcjs-dom + , jsaddle + , lens + , uri-bytestring + + other-modules: + Component.Appearing + Component.Button + Component.ConfirmDialog + Component.Form + Component.Input + Component.Link + Component.Modal + Component.ModalForm + Component.Pages + Component.Select + Component.Table + Component.Tag + Loadable + Model.Route + Util.Ajax + Util.Css + Util.Either + Util.Reflex + Util.Router + Util.Validation + Util.WaitFor + View.App + View.Header + View.Icon + View.Income.Form + View.Income.Header + View.Income.Income + View.Income.Reducer + View.Income.Table + View.Category.Form + View.Category.Category + View.Category.Reducer + View.Category.Table + View.NotFound + View.Payment.Form + View.Payment.HeaderForm + View.Payment.HeaderInfos + View.Payment.Payment + View.Payment.Reducer + View.Payment.Table + View.SignIn + View.Statistics.Chart + View.Statistics.Statistics diff --git a/client/src/Component/Appearing.hs b/client/src/Component/Appearing.hs new file mode 100644 index 0000000..e0144ca --- /dev/null +++ b/client/src/Component/Appearing.hs @@ -0,0 +1,10 @@ +module Component.Appearing + ( view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +view :: forall t m a. MonadWidget t m => m a -> m a +view = + R.divClass "g-Appearing" diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs new file mode 100644 index 0000000..153a61b --- /dev/null +++ b/client/src/Component/Button.hs @@ -0,0 +1,57 @@ +module Component.Button + ( In(..) + , Out(..) + , view + , defaultIn + ) where + +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified View.Icon as Icon + +data In t m = In + { _in_class :: Dynamic t Text + , _in_content :: m () + , _in_waiting :: Event t Bool + , _in_tabIndex :: Maybe Int + , _in_submit :: Bool + } + +defaultIn :: forall t m. MonadWidget t m => m () -> In t m +defaultIn content = In + { _in_class = R.constDyn "" + , _in_content = content + , _in_waiting = R.never + , _in_tabIndex = Nothing + , _in_submit = False + } + +data Out t = Out + { _out_clic :: Event t () + } + +view :: forall t m. MonadWidget t m => In t m -> m (Out t) +view input = do + dynWaiting <- R.holdDyn False $ _in_waiting input + + let attr = do + buttonClass <- _in_class input + waiting <- dynWaiting + return . M.fromList . catMaybes $ + [ Just ("type", if _in_submit input then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _in_tabIndex input + , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) + ] + + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _in_content input + + return $ Out + { _out_clic = R.domEvent R.Click e + } diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs new file mode 100644 index 0000000..cf26593 --- /dev/null +++ b/client/src/Component/ConfirmDialog.hs @@ -0,0 +1,49 @@ +module Component.ConfirmDialog + ( In(..) + , view + ) where + +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data In t m = In + { _in_header :: Text + , _in_confirm :: Event t () -> m (Event t ()) + } + +view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m +view input _ = + R.divClass "confirm" $ do + R.divClass "confirmHeader" $ + R.text $ _in_header input + + R.divClass "confirmContent" $ do + (confirm, cancel) <- R.divClass "buttons" $ do + + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) + + rec + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_submit = True + , Button._in_waiting = waiting + }) + + (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm + + return (result, cancel) + + return $ + ( R.leftmost [ cancel, () <$ confirm ] + , confirm + ) diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs new file mode 100644 index 0000000..6878e68 --- /dev/null +++ b/client/src/Component/Form.hs @@ -0,0 +1,12 @@ +module Component.Form + ( view + ) where + +import qualified Data.Map as M +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +view :: forall t m a. MonadWidget t m => m a -> m a +view content = + R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ + content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs new file mode 100644 index 0000000..bcff377 --- /dev/null +++ b/client/src/Component/Input.hs @@ -0,0 +1,151 @@ +module Component.Input + ( In(..) + , Out(..) + , view + , defaultIn + ) where + +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, + (&), (.~)) +import qualified Reflex.Dom as R + +import qualified Common.Util.Validation as ValidationUtil +import qualified Component.Button as Button +import qualified View.Icon as Icon + +data In a = In + { _in_hasResetButton :: Bool + , _in_label :: Text + , _in_initialValue :: Text + , _in_inputType :: Text + , _in_validation :: Text -> Validation Text a + } + +defaultIn :: In Text +defaultIn = In + { _in_hasResetButton = True + , _in_label = "" + , _in_initialValue = "" + , _in_inputType = "text" + , _in_validation = V.Success + } + +data Out t a = Out + { _out_raw :: Dynamic t Text + , _out_value :: Dynamic t (Validation Text a) + , _out_enter :: Event t () + } + +view + :: forall t m a b. MonadWidget t m + => In a + -> Event t Text -- reset + -> Event t b -- validate + -> m (Out t a) +view input reset validate = do + rec + let resetValue = R.leftmost + [ reset + , fmap (const "") resetClic + ] + + inputAttr = R.ffor value (\v -> + if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color" + then M.empty + else M.singleton "class" "filled") + + value = R._textInput_value textInput + + containerAttr = R.ffor inputError (\e -> + M.singleton "class" $ T.intercalate " " + [ "textInput" + , if Maybe.isJust e then "error" else "" + ]) + + let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v)) + inputError <- getInputError valueWithValidation validate + + (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do + + textInput <- R.el "label" $ do + textInput <- R.textInput $ R.def + & R.attributes .~ inputAttr + & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_in_initialValue input) + & R.textInputConfig_inputType .~ (_in_inputType input) + + R.divClass "label" $ + R.text (_in_label input) + + return textInput + + resetClic <- + if _in_hasResetButton input + then + Button._out_clic <$> (Button.view $ + (Button.defaultIn Icon.cross) + { Button._in_class = R.constDyn "reset" + , Button._in_tabIndex = Just (-1) + }) + else + return R.never + + R.divClass "errorMessage" $ + R.dynText . fmap (Maybe.fromMaybe "") $ inputError + + return (textInput, resetClic) + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ Out + { _out_raw = value + , _out_value = fmap snd valueWithValidation + , _out_enter = enter + } + +getInputError + :: forall t m a b c. MonadWidget t m + => Dynamic t (Text, Validation Text a) + -> Event t c + -> m (Dynamic t (Maybe Text)) +getInputError validatedValue validate = do + let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue + errorEvent = R.updated errorDynamic + delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent + fmap (fmap fst) $ R.foldDyn + (\event (err, hasBeenResetted) -> + case event of + ModifiedEvent t -> + (Nothing, T.null t) + + ValidateEvent e -> + (e, False) + + DelayEvent e -> + if hasBeenResetted then + (Nothing, False) + else + (e, False) + ) + (Nothing, False) + (R.leftmost + [ fmap (\(t, _) -> ModifiedEvent t) errorEvent + , fmap (\(_, e) -> DelayEvent e) delayedError + , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate + ]) + +validationError :: (Validation Text a) -> Maybe Text +validationError (Failure e) = Just e +validationError _ = Nothing + +data InputEvent + = ModifiedEvent Text + | DelayEvent (Maybe Text) + | ValidateEvent (Maybe Text) diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs new file mode 100644 index 0000000..1fd620e --- /dev/null +++ b/client/src/Component/Link.hs @@ -0,0 +1,33 @@ +module Component.Link + ( view + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +view :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +view href inputAttrs content = + R.elDynAttr "a" attrs (R.text content) + where + + onclickHandler = + T.intercalate ";" + [ "history.pushState(0, '', event.target.href)" + , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))" + , "return false" + ] + + attrs = + R.ffor inputAttrs (\as -> + (M.union + (M.fromList + [ ("onclick", onclickHandler) + , ("href", href) + ] + ) + as) + ) diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs new file mode 100644 index 0000000..46d3f64 --- /dev/null +++ b/client/src/Component/Modal.hs @@ -0,0 +1,117 @@ +module Component.Modal + ( In(..) + , Content + , view + ) where + +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import qualified GHCJS.DOM.Element as Element +import qualified GHCJS.DOM.Node as Node +import JSDOM.Types (JSString) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R + +import qualified Util.Reflex as ReflexUtil + +-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) +type Content t m = Event t () -> m (Event t (), Event t ()) + +data In t m = In + { _in_show :: Event t () + , _in_content :: Content t m + } + +view :: forall t m a. MonadWidget t m => In t m -> m (Event t ()) +view input = do + rec + let show = Show <$ (_in_show input) + + startHiding = + R.attachWithMaybe + (\a _ -> if a then Just StartHiding else Nothing) + (R.current canBeHidden) + (R.leftmost [ hide, curtainClick ]) + + canBeHidden <- + R.holdDyn True $ R.leftmost + [ False <$ startHiding + , True <$ endHiding + ] + + endHiding <- + R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding) + + let action = + R.leftmost [ show, startHiding, endHiding ] + + modalClass <- + R.holdDyn "" (fmap getModalClass action) + + (elem, dyn) <- + R.buildElement "div" (getAttributes <$> modalClass) $ + ReflexUtil.visibleIfEvent + (isVisible <$> action) + (R.blank >> return (R.never, R.never, R.never)) + (do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank + let curtainClick = R.domEvent R.Click curtain + (hide, content) <- R.divClass "g-Modal__Content" (_in_content input curtainClick) + return (curtainClick, hide, content)) + + + performShowEffects action elem + + let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn + let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn + let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn + + -- Delay the event in order to let time for the modal to disappear + R.delay (0.5 :: NominalDiffTime) content + +getAttributes :: Text -> LM.Map Text Text +getAttributes modalClass = + M.singleton "class" $ + T.intercalate " " [ "g-Modal", modalClass] + +performShowEffects + :: forall t m a. MonadWidget t m + => Event t Action + -> Element.Element + -> m () +performShowEffects showEvent elem = do + body <- ReflexUtil.getBody + + let showEffects = + flip fmap showEvent (\case + Show -> do + Node.appendChild body elem + Element.setClassName body ("g-Body--Modal" :: JSString) + StartHiding -> + return () + EndHiding -> do + Node.removeChild body elem + Element.setClassName body ("" :: JSString) + ) + + R.performEvent_ $ void `fmap` showEffects + +data Action + = Show + | StartHiding + | EndHiding + +getModalClass :: Action -> Text +getModalClass Show = "g-Modal--Show" +getModalClass StartHiding = "g-Modal--Hiding" +getModalClass _ = "" + +isVisible :: Action -> Bool +isVisible Show = True +isVisible StartHiding = True +isVisible EndHiding = False diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs new file mode 100644 index 0000000..c56ff88 --- /dev/null +++ b/client/src/Component/ModalForm.hs @@ -0,0 +1,71 @@ +module Component.ModalForm + ( view + , In(..) + , Out(..) + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Form as Form +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data In m t a e = In + { _in_headerLabel :: Text + , _in_form :: m (Dynamic t (Validation e a)) + , _in_ajax :: Event t a -> m (Event t (Either Text ())) + } + +data Out t = Out + { _out_hide :: Event t () + , _out_cancel :: Event t () + , _out_confirm :: Event t () + , _out_validate :: Event t () + } + +view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t) +view input = + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_in_headerLabel input) + + Form.view $ + R.divClass "formContent" $ do + rec + form <- _in_form input + + (validate, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) + + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_waiting = waiting + , Button._in_submit = True + }) + + (validate, waiting) <- WaitFor.waitFor + (_in_ajax input) + (ValidationUtil.fireValidation form confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) + + return Out + { _out_hide = R.leftmost [ cancel, () <$ validate ] + , _out_cancel = cancel + , _out_confirm = confirm + , _out_validate = validate + } diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs new file mode 100644 index 0000000..d54cd3d --- /dev/null +++ b/client/src/Component/Pages.hs @@ -0,0 +1,86 @@ +module Component.Pages + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Component.Button as Button + +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon + +data In t = In + { _in_total :: Dynamic t Int + , _in_perPage :: Int + , _in_page :: Int + } + +data Out t = Out + { _out_newPage :: Event t Int + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + newPage <- ReflexUtil.divVisibleIf ((> 0) <$> (_in_total input)) $ pageButtons input + + return $ Out + { _out_newPage = newPage + } + +pageButtons + :: forall t m. MonadWidget t m + => In t + -> m (Event t Int) +pageButtons input = do + R.divClass "pages" $ do + rec + let newPage = R.leftmost + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + ] + + currentPage <- R.holdDyn (_in_page input) newPage + + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight + + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar + + return newPage + + where maxPage = R.ffor (_in_total input) (\t -> ceiling $ toRational t / toRational (_in_perPage input)) + pageEvent = R.switch . R.current . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + +range :: Int -> Int -> [Int] +range currentPage maxPage = [start..end] + where sidePages = 2 + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- Button._out_clic <$> (Button.view $ Button.In + { Button._in_class = do + cp <- currentPage + p <- page + if cp == Just p then "page current" else "page" + , Button._in_content = content + , Button._in_waiting = R.never + , Button._in_tabIndex = Nothing + , Button._in_submit = False + }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs new file mode 100644 index 0000000..70f5f58 --- /dev/null +++ b/client/src/Component/Select.hs @@ -0,0 +1,80 @@ +module Component.Select + ( view + , In(..) + , Out(..) + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validation (Validation) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import qualified Util.Validation as ValidationUtil + +data (Reflex t) => In t a b c = In + { _in_label :: Text + , _in_initialValue :: a + , _in_value :: Event t a + , _in_values :: Dynamic t (Map a Text) + , _in_reset :: Event t b + , _in_isValid :: a -> Validation Text a + , _in_validate :: Event t c + } + +data Out t a = Out + { _out_raw :: Dynamic t a + , _out_value :: Dynamic t (Validation Text a) + } + +view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a) +view input = do + rec + let containerAttr = R.ffor showedError (\e -> + M.singleton "class" $ T.intercalate " " + [ "input selectInput" + , if Maybe.isJust e then "error" else "" + ]) + + validatedValue = + fmap (_in_isValid input) value + + maybeError = + fmap ValidationUtil.maybeError validatedValue + + showedError <- R.holdDyn Nothing $ R.leftmost + [ Nothing <$ _in_reset input + , R.updated maybeError + , R.attachWith const (R.current maybeError) (_in_validate input) + ] + + value <- R.elDynAttr "div" containerAttr $ do + let initialValue = _in_initialValue input + + let setValue = R.leftmost + [ initialValue <$ (_in_reset input) + , _in_value input + ] + + value <- R.el "label" $ do + R.divClass "label" $ + R.text (_in_label input) + + R._dropdown_value <$> + R.dropdown + initialValue + (_in_values input) + (R.def { R._dropdownConfig_setValue = setValue }) + + R.divClass "errorMessage" . R.dynText $ + R.ffor showedError (Maybe.fromMaybe "") + + return value + + return Out + { _out_raw = value + , _out_value = validatedValue + } diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs new file mode 100644 index 0000000..1482f91 --- /dev/null +++ b/client/src/Component/Table.hs @@ -0,0 +1,105 @@ +module Component.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon + +data In m t h r = In + { _in_headerLabel :: h -> Text + , _in_rows :: [r] + , _in_cell :: h -> r -> m () + , _in_cloneModal :: r -> Modal.Content t m + , _in_editModal :: r -> Modal.Content t m + , _in_deleteModal :: r -> Modal.Content t m + , _in_canEdit :: r -> Bool + , _in_canDelete :: r -> Bool + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t) +view input = + R.divClass "table" $ do + rec + result <- R.divClass "lines" $ do + + R.divClass "header" $ do + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _in_headerLabel input header + + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + + flip mapM (_in_rows input) $ \row -> + R.divClass "row" $ do + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" $ + _in_cell input header row + + cloneButton <- + R.divClass "cell button" $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.clone) + + clone <- + Modal.view $ Modal.In + { Modal._in_show = cloneButton + , Modal._in_content = _in_cloneModal input row + } + + let visibleIf cond = + R.elAttr + "div" + (if cond then M.empty else M.singleton "style" "display:none") + + editButton <- + R.divClass "cell button" $ + visibleIf (_in_canEdit input row) $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.edit) + + edit <- + Modal.view $ Modal.In + { Modal._in_show = editButton + , Modal._in_content = _in_editModal input row + } + + deleteButton <- + R.divClass "cell button" $ + visibleIf (_in_canDelete input row) $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.delete) + + delete <- + Modal.view $ Modal.In + { Modal._in_show = deleteButton + , Modal._in_content = _in_deleteModal input row + } + + return (clone, edit, delete) + + let add = R.leftmost . map (\(a, _, _) -> a) $ result + edit = R.leftmost . map (\(_, a, _) -> a) $ result + delete = R.leftmost . map (\(_, _, a) -> a) $ result + + return $ Out + { _out_add = add + , _out_edit = edit + , _out_delete = delete + } diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs new file mode 100644 index 0000000..f75b8d3 --- /dev/null +++ b/client/src/Component/Tag.hs @@ -0,0 +1,27 @@ +module Component.Tag + ( In(..) + , view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +data In = In + { _in_text :: Text + , _in_color :: Text + } + +view :: forall t m a. MonadWidget t m => In -> m () +view input = + R.elAttr "span" attrs $ + R.text $ _in_text input + + where + attrs = + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _in_color input ]) + ] diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs new file mode 100644 index 0000000..4806b08 --- /dev/null +++ b/client/src/Loadable.hs @@ -0,0 +1,109 @@ +module Loadable + ( Loadable (..) + , fromEither + , fromEvent + , viewHideValueWhileLoading + , viewShowValueWhileLoading + ) where + +import qualified Data.Map as M +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Data.Functor (Functor) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +data Loadable t + = Loading + | Error Text + | Loaded t + deriving (Eq, Show) + +instance Functor Loadable where + fmap f Loading = Loading + fmap f (Error e) = Error e + fmap f (Loaded x) = Loaded (f x) + +instance Applicative Loadable where + pure x = Loaded x + + Loading <*> _ = Loading + (Error e) <*> _ = Error e + (Loaded f) <*> Loading = Loading + (Loaded f) <*> (Error e) = Error e + (Loaded f) <*> (Loaded x) = Loaded (f x) + +instance Monad Loadable where + Loading >>= f = Loading + (Error e) >>= f = Error e + (Loaded x) >>= f = f x + +fromEither :: forall a b. Either Text b -> Loadable b +fromEither (Left err) = Error err +fromEither (Right value) = Loaded value + +fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) +fromEvent = + R.foldDyn + (\res _ -> case res of + Left err -> Error err + Right t -> Loaded t + ) + Loading + +viewHideValueWhileLoading :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +viewHideValueWhileLoading f loadable = + case loadable of + Loading -> + (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing + + Error err -> + R.text err >> return Nothing + + Loaded x -> + Just <$> f x + +viewShowValueWhileLoading + :: forall t m a b. (MonadWidget t m, Eq a) + => Dynamic t (Loadable a) + -> (a -> m b) + -> m (Event t (Maybe b)) +viewShowValueWhileLoading loadable f = do + + value <- + (R.foldDyn + (\l v1 -> + case l of + Loaded v2 -> Just v2 + _ -> v1) + Nothing + (R.updated loadable)) >>= R.holdUniqDyn + + withLoader (fmap ((==) Loading) loadable) $ + R.dyn . R.ffor value $ \case + Nothing -> return Nothing + Just x -> Just <$> f x + +withLoader + :: forall t m a. MonadWidget t m + => Dynamic t Bool + -> m a + -> m a +withLoader isLoading block = + R.divClass "g-Loadable" $ do + res <- R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block + R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ + R.divClass "spinner" R.blank + return res + + where + spinnerAttrs l = M.singleton "class" $ + "g-Loadable__Spinner" + <> (if l then " g-Loadable__Spinner--Loading" else "") + + blockAttrs l = M.singleton "class" $ + "g-Loadable__Content" + <> (if l then " g-Loadable__Content--Loading" else "") diff --git a/client/src/Main.hs b/client/src/Main.hs new file mode 100644 index 0000000..c71b0f0 --- /dev/null +++ b/client/src/Main.hs @@ -0,0 +1,39 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import qualified Data.JSString.Text as Dom +import qualified Data.Text.Encoding as T +import qualified JSDOM as Dom +import qualified JSDOM.Generated.HTMLElement as Dom +import qualified JSDOM.Generated.NonElementParentNode as Dom +import JSDOM.Types (HTMLElement (..), JSM, + JSString) +import qualified JSDOM.Types as Dom +import Prelude hiding (error, init) + +import Common.Model (Init) +import qualified Common.Msg as Msg + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + App.widget initResult + +readInit :: JSM (Maybe Init) +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document ("init" :: JSString) + + case initNode of + Just node -> do + text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> Nothing + _ -> + return Nothing diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs new file mode 100644 index 0000000..f92e9be --- /dev/null +++ b/client/src/Model/Route.hs @@ -0,0 +1,11 @@ +module Model.Route + ( Route(..) + ) where + +data Route + = RootRoute + | IncomeRoute + | CategoryRoute + | StatisticsRoute + | NotFoundRoute + deriving (Eq, Show) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs new file mode 100644 index 0000000..dcfd402 --- /dev/null +++ b/client/src/Util/Ajax.hs @@ -0,0 +1,139 @@ +module Util.Ajax + ( getNow + , get + , post + , postAndParseResult + , put + , putAndParseResult + , delete + ) where + +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, IsXhrPayload, + MonadWidget, XhrRequest, + XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R + +import Loadable (Loadable) +import qualified Loadable + +getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) +getNow url = do + postBuild <- R.getPostBuild + get (url <$ postBuild) + >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise + >>= Loadable.fromEvent + +get + :: forall t m a. (MonadWidget t m, FromJSON a) + => Event t Text + -> m (Event t (Either Text a)) +get url = + fmap getJsonResult <$> + R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) + +post + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +post url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "POST" url <$> input) + +postAndParseResult + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) + => Text + -> Event t a + -> m (Event t (Either Text b)) +postAndParseResult url input = + fmap getJsonResult <$> + R.performRequestAsync (jsonRequest "POST" url <$> input) + +put + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +put url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) + +putAndParseResult + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) + => Text + -> Event t a + -> m (Event t (Either Text b)) +putAndParseResult url input = + fmap getJsonResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) + +delete + :: forall t m a. (MonadWidget t m) + => Dynamic t Text + -> Event t () + -> m (Event t (Either Text Text)) +delete url fire = do + fmap getResult <$> + (R.performRequestAsync $ + R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) + +checkResult :: XhrResponse -> Either Text () +checkResult response = + () <$ getResult response + +getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a +getJsonResult response = + case getResult response of + Left l -> Left l + Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r) + +getResult :: XhrResponse -> Either Text Text +getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" + +request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a +request method url payload = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = payload + } + in + R.xhrRequest method url config + +jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString +jsonRequest method url payload = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload + } + in + R.xhrRequest method url config diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs new file mode 100644 index 0000000..804b10f --- /dev/null +++ b/client/src/Util/Css.hs @@ -0,0 +1,9 @@ +module Util.Css + ( classes + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +classes :: [(Text, Bool)] -> Text +classes = T.unwords . map fst . filter snd diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs new file mode 100644 index 0000000..e76bc8a --- /dev/null +++ b/client/src/Util/Either.hs @@ -0,0 +1,7 @@ +module Util.Either + ( eitherToMaybe + ) where + +eitherToMaybe :: forall a b. Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs new file mode 100644 index 0000000..aa5cebb --- /dev/null +++ b/client/src/Util/Reflex.hs @@ -0,0 +1,59 @@ +module Util.Reflex + ( visibleIfDyn + , visibleIfEvent + , divVisibleIf + , divClassVisibleIf + , flatten + , flattenTuple + , getBody + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a) +visibleIfDyn cond empty content = + R.dyn $ R.ffor cond $ \case + True -> content + False -> empty + +visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +visibleIfEvent cond empty content = + R.widgetHold empty $ + R.ffor cond $ \case + True -> content + False -> empty + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content + +flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a) +flatten e = do + dyn <- R.holdDyn R.never e + return $ R.switchDyn dyn + +flattenTuple + :: forall t m a b. MonadWidget t m + => Event t (Event t a, Event t b) + -> m (Event t a, Event t b) +flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e) + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs new file mode 100644 index 0000000..e9d0a1a --- /dev/null +++ b/client/src/Util/Router.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Util.Router ( + -- == High-level routers + route + , route' + , partialPathRoute + + -- = Low-level URL bar access + , getLoc + , getURI + , getUrlText + , uriOrigin + , URI + + -- = History movement + , goForward + , goBack + ) where + +------------------------------------------------------------------------------ +import Control.Lens ((&), (.~), (^.)) +import Control.Monad.Fix (MonadFix) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHCJS.DOM (currentDocumentUnchecked, + currentWindowUnchecked) +import GHCJS.DOM.Document (createEvent) +import GHCJS.DOM.Event (initEvent) +import GHCJS.DOM.EventM (on) +import GHCJS.DOM.EventTarget (dispatchEvent_) +import GHCJS.DOM.History (History, back, forward, + pushState) +import GHCJS.DOM.Location (getHref) +import GHCJS.DOM.PopStateEvent +import GHCJS.DOM.Types (Location (..), + PopStateEvent (..)) +import GHCJS.DOM.Types (MonadJSM, uncheckedCastTo) +import qualified GHCJS.DOM.Types as DOM +import GHCJS.DOM.Window (getHistory, getLocation) +import GHCJS.DOM.WindowEventHandlers (popState) +import GHCJS.Foreign (isFunction) +import GHCJS.Marshal.Pure (pFromJSVal) +import Language.Javascript.JSaddle (JSM, Object (..), ghcjsPure, + liftJSM) +import qualified Language.Javascript.JSaddle as JS +import Reflex.Dom.Core hiding (EventName, Window) +import qualified URI.ByteString as U +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------- +-- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic +-- routing of a widget +-- These sources of URL-bar change will be reflected in the output URI +-- - Input events to 'route' +-- - Browser Forward/Back button clicks +-- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls +-- - Any URL changes followed by a popState event +-- But external calls to pushState that don't manually fire a popState +-- won't be detected +route + :: forall t m. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m)) + => Event t T.Text + -> m (Dynamic t (U.URIRef U.Absolute)) +route pushTo = do + loc0 <- getURI + + _ <- performEvent $ ffor pushTo $ \t -> do + let newState = Just t + withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text) + liftJSM dispatchEvent' + + locUpdates <- getPopState + holdDyn loc0 locUpdates + +route' + :: forall t m a b. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => (URI -> a -> URI) + -> (URI -> b) + -> Event t a + -> m (Dynamic t b) +route' encode decode routeUpdate = do + rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates) + let urlUpdates = attachWith encode (current rUri) routeUpdate + return $ decode <$> rUri + + +------------------------------------------------------------------------------- +-- | Route a single page app according to the part of the path after +-- pathBase +partialPathRoute + :: forall t m. + ( MonadHold t m + , PostBuild t m + , DomBuilder t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => T.Text -- ^ The path segments not related to SPA routing + -- (leading '/' will be added automaticaly) + -> Event t T.Text -- ^ Updates to the path segments used for routing + -- These values will be appended to the base path + -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing +partialPathRoute pathBase pathUpdates = do + route' (flip updateUrl) parseParts pathUpdates + where + + rootPathBase :: T.Text + rootPathBase = + if T.null pathBase then + "" + else + "/" <> cleanT pathBase + + toPath :: T.Text -> BS.ByteString + toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath + + updateUrl :: T.Text -> URI -> URI + updateUrl updateParts u = u & U.pathL .~ toPath updateParts + + parseParts :: URI -> [T.Text] + parseParts u = + maybe (error $ pfxErr u pathBase) + (T.splitOn "/" . T.decodeUtf8 . cleanB) . + BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $ + cleanB (u ^. U.pathL) + + cleanT = T.dropWhile (=='/') + cleanB = BS.dropWhile (== '/') + + +------------------------------------------------------------------------------- +uriOrigin :: U.URIRef U.Absolute -> T.Text +uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r' + where + r' = r { U.uriPath = mempty + , U.uriQuery = mempty + , U.uriFragment = mempty + } + + +------------------------------------------------------------------------------- +getPopState + :: forall t m. + ( MonadHold t m + , TriggerEvent t m + , MonadJSM m) => m (Event t URI) +getPopState = do + window <- currentWindowUnchecked + wrapDomEventMaybe window (`on` popState) $ do + loc <- getLocation window + locStr <- getHref loc + return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr) + + +------------------------------------------------------------------------------- +goForward :: (HasJSContext m, MonadJSM m) => m () +goForward = withHistory forward + + +------------------------------------------------------------------------------- +goBack :: (HasJSContext m, MonadJSM m) => m () +goBack = withHistory back + + +------------------------------------------------------------------------------- +withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a +withHistory act = do + w <- currentWindowUnchecked + h <- getHistory w + act h + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window +getLoc :: (HasJSContext m, MonadJSM m) => m Location +getLoc = do + win <- currentWindowUnchecked + loc <- getLocation win + return loc + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the URL text of a window +getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text +getUrlText = getLoc >>= getHref + + +------------------------------------------------------------------------------- +type URI = U.URIRef U.Absolute + + +------------------------------------------------------------------------------- +getURI :: (HasJSContext m, MonadJSM m) => m URI +getURI = do + l <- getUrlText + return $ either (error "No parse of window location") id . + U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l + + +dispatchEvent' :: JSM () +dispatchEvent' = do + window <- currentWindowUnchecked + obj@(Object o) <- JS.create + JS.objSetPropertyByName obj ("cancelable" :: Text) True + JS.objSetPropertyByName obj ("bubbles" :: Text) True + JS.objSetPropertyByName obj ("view" :: Text) window + event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case + True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o + False -> do + doc <- currentDocumentUnchecked + event <- createEvent doc ("PopStateEvent" :: Text) + initEvent event ("popstate" :: Text) True True + JS.objSetPropertyByName obj ("view" :: Text) window + return $ uncheckedCastTo PopStateEvent event + + dispatchEvent_ window event + + +------------------------------------------------------------------------------- +hush :: Either e a -> Maybe a +hush (Right a) = Just a +hush _ = Nothing + + +------------------------------------------------------------------------------- +pfxErr :: URI -> T.Text -> String +pfxErr pn pathBase = + T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn) + <> ") without expected prefix (" <> pathBase <> ")" diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs new file mode 100644 index 0000000..50f2468 --- /dev/null +++ b/client/src/Util/Validation.hs @@ -0,0 +1,36 @@ +module Util.Validation + ( nelError + , toMaybe + , maybeError + , fireValidation + ) where + +import Control.Monad (join) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import Data.Text (Text) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as Validation +import Reflex.Dom (Dynamic, Event, Reflex) +import qualified Reflex.Dom as R + +nelError :: Validation a b -> Validation (NonEmpty a) b +nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success + +toMaybe :: Validation a b -> Maybe b +toMaybe (Success s) = Just s +toMaybe (Failure _) = Nothing + +maybeError :: Validation a b -> Maybe a +maybeError (Success _) = Nothing +maybeError (Failure e) = Just e + +fireValidation + :: forall t a b c. Reflex t + => Dynamic t (Validation a b) + -> Event t c + -> Event t b +fireValidation value validate = + R.fmapMaybe + (Validation.validation (const Nothing) Just) + (R.tag (R.current value) validate) diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs new file mode 100644 index 0000000..fe7b733 --- /dev/null +++ b/client/src/Util/WaitFor.hs @@ -0,0 +1,17 @@ +module Util.WaitFor + ( waitFor + ) where + +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +waitFor + :: forall t m a b. MonadWidget t m + => (Event t a -> m (Event t b)) + -> Event t a + -> m (Event t b, Event t Bool) +waitFor op input = do + result <- op input >>= R.debounce (0.5 :: NominalDiffTime) + let waiting = R.leftmost [ True <$ input , False <$ result ] + return (result, waiting) diff --git a/client/src/View/App.hs b/client/src/View/App.hs new file mode 100644 index 0000000..71f0234 --- /dev/null +++ b/client/src/View/App.hs @@ -0,0 +1,108 @@ +module View.App + ( widget + ) where + +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn +import qualified View.Statistics.Statistics as Statistics + +widget :: Maybe Init -> IO () +widget init = + R.mainWidget $ R.divClass "app" $ do + + route <- getRoute + + rec + header <- Header.view $ Header.In + { Header._in_init = initState + , Header._in_route = route + } + + initState <- + R.foldDyn + const + init + (R.leftmost $ + [ initEvent + , Nothing <$ (Header._out_signOut header) + ]) + + initEvent <- + (R.dyn . R.ffor initState $ \case + Nothing -> do + signIn <- SignIn.view + return (Just <$> SignIn._out_success signIn) + + Just i -> do + signedWidget i route + return R.never) >>= ReflexUtil.flatten + + return () + +signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget init route = do + R.dyn . R.ffor route $ \case + RootRoute -> + Payment.view $ Payment.In + { Payment._in_currentUser = _init_currentUser init + , Payment._in_currency = _init_currency init + , Payment._in_users = _init_users init + } + + IncomeRoute -> + Income.view $ Income.In + { Income._in_currentUser = _init_currentUser init + , Income._in_currency = _init_currency init + , Income._in_users = _init_users init + } + + CategoryRoute -> + Category.view $ Category.In + { Category._in_currentUser = _init_currentUser init + , Category._in_currency = _init_currency init + , Category._in_users = _init_users init + } + + StatisticsRoute -> + Statistics.view $ Statistics.In + { Statistics._in_currency = _init_currency init + } + + NotFoundRoute -> + NotFound.view + + return () + +getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route) +getRoute = do + r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never + return . R.ffor r $ \case + [""] -> + RootRoute + + ["income"] -> + IncomeRoute + + ["category"] -> + CategoryRoute + + ["statistics"] -> + StatisticsRoute + + _ -> + NotFoundRoute diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs new file mode 100644 index 0000000..5b41bb6 --- /dev/null +++ b/client/src/View/Category/Category.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Category.Category + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, CategoryPage (..), Currency, + User, UserId) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Category.Form as Form +import qualified View.Category.Reducer as Reducer +import qualified View.Category.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + categoryPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addCategory = R.leftmost [ headerAddCategory, tableAddCategory ] + , Reducer._in_editCategory = editCategory + , Reducer._in_deleteCategory = deleteCategory + } + + let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddCategory <- eventFromResult $ (\(a, _, _) -> a) + tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading categoryPage $ + \(CategoryPage page categories usedCategories count) -> do + header <- headerView + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_categories = categories + , Table._in_usedCategories = usedCategories + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () + +headerView :: forall t m. MonadWidget t m => m (Event t ()) +headerView = + R.divClass "withMargin" $ + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs new file mode 100644 index 0000000..d91fc2e --- /dev/null +++ b/client/src/View/Category/Form.hs @@ -0,0 +1,117 @@ +module View.Category.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Category as CategoryValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Category + | Edit Category + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/category" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + name <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Name + , Input._in_initialValue = name + , Input._in_validation = CategoryValidation.name + }) + (name <$ reset) + confirm) + + color <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Color + , Input._in_initialValue = color + , Input._in_inputType = "color" + , Input._in_hasResetButton = False + , Input._in_validation = CategoryValidation.color + }) + (color <$ reset) + confirm) + + return $ do + n <- name + c <- color + return . V.Success $ mkPayload n c + + op = _in_operation input + + name = + case op of + New -> "" + Clone c -> _category_name c + Edit c -> _category_name c + + color = + case op of + New -> "" + Clone c -> _category_color c + Edit c -> _category_color c + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Category_Edit + _ -> Msg.get Msg.Category_Add + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateCategoryForm a b diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs new file mode 100644 index 0000000..5ad0ddb --- /dev/null +++ b/client/src/View/Category/Reducer.hs @@ -0,0 +1,59 @@ +module View.Category.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CategoryPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addCategory :: Event t a + , _in_editCategory :: Event t b + , _in_deleteCategory :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addCategory input + , R.tag (R.current currentPage) (_in_editCategory input) + , R.tag (R.current currentPage) (_in_deleteCategory input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/categories?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs new file mode 100644 index 0000000..90d013d --- /dev/null +++ b/client/src/View/Category/Table.hs @@ -0,0 +1,93 @@ +module View.Category.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, Currency, + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Category.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_usedCategories :: [CategoryId] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_categories input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Clone category + } + , Table._in_editModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Edit category + } + , Table._in_deleteModal = \category -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Category_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_canEdit = const True + , Table._in_canDelete = not . flip elem (_in_usedCategories input) . _category_id + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | ColorHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Category_Name +headerLabel ColorHeader = Msg.get Msg.Category_Color + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m () +cell users currency header category = + case header of + NameHeader -> + R.text $ _category_name category + + ColorHeader -> + Tag.view $ Tag.In + { Tag._in_text = _category_name category + , Tag._in_color = _category_color category + } diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs new file mode 100644 index 0000000..ff9f40a --- /dev/null +++ b/client/src/View/Header.hs @@ -0,0 +1,123 @@ +module View.Header + ( view + , In(..) + , Out(..) + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Link as Link +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon + +data In t = In + { _in_init :: Dynamic t (Maybe Init) + , _in_route :: Dynamic t Route + } + +data Out t = Out + { _out_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => (In t) -> m (Out t) +view input = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Msg.get Msg.App_Title + + let showLinks = Maybe.isJust <$> _in_init input + + signOut <- R.el "div" $ do + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten + + return $ Out + { _out_signOut = signOut + } + +links :: forall t m. MonadWidget t m => Dynamic t Route -> m () +links route = do + Link.view + "/" + (R.ffor route (attrs RootRoute)) + (Msg.get Msg.Payment_Title) + + Link.view + "/income" + (R.ffor route (attrs IncomeRoute)) + (Msg.get Msg.Income_Title) + + Link.view + "/category" + (R.ffor route (attrs CategoryRoute)) + (Msg.get Msg.Category_Title) + + Link.view + "/statistics" + (R.ffor route (attrs StatisticsRoute)) + (Msg.get Msg.Statistics_Title) + + where + attrs linkRoute currentRoute = + M.singleton "class" $ + CssUtil.classes + [ ("item", True) + , ("current", linkRoute == currentRoute) + ] + +nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ()) +nameSignOut init = + case init of + Just init -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Button.view $ + (Button.defaultIn Icon.signOut) + { Button._in_class = R.constDyn "signOut item" + , Button._in_waiting = waiting + } + let signOutClic = Button._out_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/Icon.hs b/client/src/View/Icon.hs new file mode 100644 index 0000000..cc2ef3f --- /dev/null +++ b/client/src/View/Icon.hs @@ -0,0 +1,71 @@ +module View.Icon + ( clone + , cross + , delete + , edit + , loading + , doubleLeft + , doubleLeftBar + , doubleRight + , doubleRightBar + , signOut + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank + +doubleLeft :: forall t m. MonadWidget t m => m () +doubleLeft = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank + +doubleLeftBar :: forall t m. MonadWidget t m => m () +doubleLeftBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank + +doubleRight :: forall t m. MonadWidget t m => m () +doubleRight = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +doubleRightBar :: forall t m. MonadWidget t m => m () +doubleRightBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs new file mode 100644 index 0000000..59f6a0d --- /dev/null +++ b/client/src/View/Income/Form.hs @@ -0,0 +1,119 @@ +module View.Income.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..), Income (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Income as IncomeValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Income + | Edit Income + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/income" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + amount <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Amount + , Input._in_initialValue = amount + , Input._in_validation = IncomeValidation.amount + }) + (amount <$ reset) + confirm) + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + let initialDate = T.pack . Calendar.showGregorian $ date currentDay + + date <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Date + , Input._in_initialValue = initialDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = IncomeValidation.date + }) + (initialDate <$ reset) + confirm) + + return $ do + a <- amount + d <- date + return . V.Success $ mkPayload a d + + op = _in_operation input + + amount = + case op of + New -> "" + Clone i -> T.pack . show . _income_amount $ i + Edit i -> T.pack . show . _income_amount $ i + + date currentDay = + case op of + Edit i -> _income_date i + _ -> currentDay + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Income_Edit + _ -> Msg.get Msg.Income_AddLong + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs new file mode 100644 index 0000000..a26e16a --- /dev/null +++ b/client/src/View/Income/Header.hs @@ -0,0 +1,77 @@ +module View.Income.Header + ( view + , In(..) + , Out(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Clock +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Income (..), + IncomeHeader (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified View.Income.Form as Form + +data In t = In + { _in_users :: [User] + , _in_header :: IncomeHeader + , _in_currency :: Currency + } + +data Out t = Out + { _out_add :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = + R.divClass "withMargin" $ do + + currentTime <- liftIO Clock.getCurrentTime + + case _incomeHeader_since $ _in_header input of + Nothing -> + R.blank + + Just since -> + R.el "div" $ do + + R.el "h1" $ do + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since)) + + R.el "ul" $ + flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) -> + R.el "li" $ + R.text $ + T.intercalate " " + [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input) + , "−" + , Format.price (_in_currency input) amount + ] + + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + addIncome <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Income_AddLong) + + addIncome <- Modal.view $ Modal.In + { Modal._in_show = addIncome + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return $ Out + { _out_add = addIncome + } diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs new file mode 100644 index 0000000..7be8091 --- /dev/null +++ b/client/src/View/Income/Income.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Income.Income + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Income (..), IncomePage (..), + User, UserId) + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Income.Header as Header +import qualified View.Income.Reducer as Reducer +import qualified View.Income.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + incomePage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] + , Reducer._in_editIncome = editIncome + , Reducer._in_deleteIncome = deleteIncome + } + + let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading incomePage $ + \(IncomePage page header incomes count) -> do + header <- Header.view $ Header.In + { Header._in_users = _in_users input + , Header._in_header = header + , Header._in_currency = _in_currency input + } + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs new file mode 100644 index 0000000..ea9f664 --- /dev/null +++ b/client/src/View/Income/Reducer.hs @@ -0,0 +1,59 @@ +module View.Income.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (IncomePage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addIncome :: Event t a + , _in_editIncome :: Event t b + , _in_deleteIncome :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addIncome input + , R.tag (R.current currentPage) (_in_editIncome input) + , R.tag (R.current currentPage) (_in_deleteIncome input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/incomes?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs new file mode 100644 index 0000000..7b7940d --- /dev/null +++ b/client/src/View/Income/Table.hs @@ -0,0 +1,93 @@ +module View.Income.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Income (..), User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Income.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_incomes :: [Income] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_incomes input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \income -> + Form.view $ Form.In + { Form._in_operation = Form.Clone income + } + , Table._in_editModal = \income -> + Form.view $ Form.In + { Form._in_operation = Form.Edit income + } + , Table._in_deleteModal = \income -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Income_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId + , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m () +cell users currency header income = + case header of + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users + + DateHeader -> + R.text . Format.longDay . _income_date $ income + + AmountHeader -> + R.text . Format.price currency . _income_amount $ income diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs new file mode 100644 index 0000000..1597849 --- /dev/null +++ b/client/src/View/NotFound.hs @@ -0,0 +1,20 @@ +module View.NotFound + ( view + ) where + +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component.Link as Link + +view :: forall t m. MonadWidget t m => m () +view = + R.divClass "notfound" $ do + R.text (Msg.get Msg.NotFound_Message) + + Link.view + "/" + (R.constDyn $ M.singleton "class" "link") + (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs new file mode 100644 index 0000000..6c31fad --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,199 @@ +module View.Payment.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Payment as PaymentValidation + +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Component.Select as Select +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil + +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t + , _in_frequency :: Frequency + } + +data Operation t + = New + | Clone Payment + | Edit Payment + +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m +view input cancel = do + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation (NonEmpty Text) Value)) + form reset confirm = do + name <- Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Name + , Input._in_initialValue = name + , Input._in_validation = PaymentValidation.name + }) + (name <$ reset) + confirm + + cost <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Cost + , Input._in_initialValue = cost + , Input._in_validation = PaymentValidation.cost + }) + (cost <$ reset) + confirm) + + currentDate <- date + + date <- + case frequency of + Punctual -> do + Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = currentDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date + }) + (currentDate <$ reset) + confirm) + Monthly -> + return . R.constDyn $ currentDate + + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) + + category <- Select._out_value <$> (Select.view $ Select.In + { Select._in_label = Msg.get Msg.Payment_Category + , Select._in_initialValue = category + , Select._in_value = setCategory + , Select._in_values = R.constDyn categories + , Select._in_reset = category <$ reset + , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) + , Select._in_validate = confirm + }) + + return $ do + n <- Input._out_value name + c <- cost + d <- date + cat <- category + return (mkPayload + <$> ValidationUtil.nelError n + <*> V.Success c + <*> V.Success d + <*> ValidationUtil.nelError cat + <*> V.Success frequency) + + frequencies = + M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_in_categories input) $ \c -> + (_category_id c, _category_name c) + + category = + case op of + New -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + + op = _in_operation input + + name = + case op of + New -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + frequency = + case op of + New -> _in_frequency input + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..1915841 --- /dev/null +++ b/client/src/View/Payment/HeaderForm.hs @@ -0,0 +1,85 @@ +module View.Payment.HeaderForm + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, Currency, Frequency (..), + Income (..), Payment (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.Select as Select +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data In t = In + { _in_reset :: Event t () + , _in_categories :: [Category] + } + +data Out t = Out + { _out_search :: Event t Text + , _out_frequency :: Event t Frequency + , _out_addPayment :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = + R.divClass "g-PaymentHeaderForm" $ do + + (searchName, frequency) <- R.el "div" $ do + + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + frequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + return (searchName, frequency) + + addPaymentButton <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" + }) + + addPayment <- + (R.dyn . R.ffor frequency $ \frequency -> + Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.New + , Form._in_frequency = frequency + } + }) >>= ReflexUtil.flatten + + return $ Out + { _out_search = R.updated searchName + , _out_frequency = R.updated frequency + , _out_addPayment = addPayment + } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..f84ee1f --- /dev/null +++ b/client/src/View/Payment/HeaderInfos.hs @@ -0,0 +1,94 @@ +module View.Payment.HeaderInfos + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, ExceedingPayer (..), + Payment (..), PaymentHeader (..), + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In t = In + { _in_users :: [User] + , _in_currency :: Currency + , _in_header :: PaymentHeader + , _in_paymentCount :: Int + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = + R.divClass "g-PaymentHeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) + + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) + + where + header = _in_header input + +exceedingPayers + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> [ExceedingPayer] + -> m () +exceedingPayers users currency payers = + R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $ + flip mapM_ payers $ \payer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text $ + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount payer + +infos + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> Map UserId Int + -> Int + -> m () +infos users currency repartition paymentCount = + R.divClass "g-PaymentHeaderInfos__Repartition" $ do + + R.elClass "span" "total" $ do + R.text $ + Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency (M.foldl (+) 0 repartition)) + + R.elClass "span" "partition" . R.text $ + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . M.toList + $ repartition + in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs new file mode 100644 index 0000000..26444d7 --- /dev/null +++ b/client/src/View/Payment/Payment.hs @@ -0,0 +1,101 @@ +module View.Payment.Payment + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentId, + PaymentPage (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderForm as HeaderForm +import qualified View.Payment.HeaderInfos as HeaderInfos +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table + +data In t = In + { _in_currentUser :: UserId + , _in_users :: [User] + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + + categories <- AjaxUtil.getNow "api/allCategories" + + R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do + + rec + paymentPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_search = HeaderForm._out_search form + , Reducer._in_frequency = HeaderForm._out_frequency form + , Reducer._in_addPayment = addPayment + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + let addPayment = + R.leftmost + [ tableAddPayment + , HeaderForm._out_addPayment form + ] + + page <- eventFromResult $ Pages._out_newPage . snd + tableAddPayment <- eventFromResult $ Table._out_add . fst + editPayment <- eventFromResult $ Table._out_edit . fst + deletePayment <- eventFromResult $ Table._out_delete . fst + + form <- HeaderForm.view $ HeaderForm.In + { HeaderForm._in_reset = () <$ addPayment + , HeaderForm._in_categories = categories + } + + result <- Loadable.viewShowValueWhileLoading paymentPage $ + \(PaymentPage page frequency header payments count) -> do + + HeaderInfos.view $ HeaderInfos.In + { HeaderInfos._in_users = _in_users input + , HeaderInfos._in_currency = _in_currency input + , HeaderInfos._in_header = header + , HeaderInfos._in_paymentCount = count + } + + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_frequency = frequency + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (table, pages) + + return () + + return () diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs new file mode 100644 index 0000000..3fe59b2 --- /dev/null +++ b/client/src/View/Payment/Reducer.hs @@ -0,0 +1,110 @@ +module View.Payment.Reducer + ( perPage + , reducer + , In(..) + , Params(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Frequency (..), PaymentPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_search :: Event t Text + , _in_frequency :: Event t Frequency + , _in_addPayment :: Event t a + , _in_editPayment :: Event t b + , _in_deletePayment :: Event t c + } + +data Params = Params + { _params_page :: Int + , _params_search :: Text + , _params_frequency :: Frequency + } deriving (Show) + +initParams = Params 1 "" Punctual + +data Msg + = Page Int + | Search Text + | Frequency Common.Model.Frequency + | ResetSearch + deriving Show + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer input = do + + postBuild <- R.getPostBuild + + debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input) + + params <- R.foldDynMaybe + (\msg params -> case msg of + Page page -> + Just $ params { _params_page = page } + + Search "" -> + if _params_search params == "" then + Nothing + + else + Just $ initParams { _params_frequency = _params_frequency params } + + Search search -> + Just $ params { _params_search = search, _params_page = _params_page initParams } + + Frequency frequency -> + Just $ params { _params_frequency = frequency, _params_page = _params_page initParams } + + ResetSearch -> + Just $ initParams { _params_frequency = _params_frequency params } + ) + initParams + (R.leftmost + [ Page <$> _in_page input + , Search <$> debouncedSearch + , Frequency <$> _in_frequency input + , ResetSearch <$ _in_addPayment input + ]) + + let paramsEvent = + R.leftmost + [ initParams <$ postBuild + , R.updated params + , R.tag (R.current params) (_in_editPayment input) + , R.tag (R.current params) (_in_deletePayment input) + ] + + getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ paramsEvent + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl (Params page search frequency) = + "api/payments?page=" + <> (T.pack . show $ page) + <> "&perPage=" + <> (T.pack . show $ perPage) + <> "&search=" + <> search + <> "&frequency=" + <> (T.pack $ show frequency) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs new file mode 100644 index 0000000..bfa0fb9 --- /dev/null +++ b/client/src/View/Payment/Table.hs @@ -0,0 +1,143 @@ +module View.Payment.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, + Frequency (..), Payment (..), + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_frequency :: Frequency + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel (_in_frequency input) + , Table._in_rows = _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_frequency input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.Clone payment + , Form._in_frequency = _in_frequency input + } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.Edit payment + , Form._in_frequency = _in_frequency input + } + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user + , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Frequency -> Header -> Text +headerLabel _ NameHeader = Msg.get Msg.Payment_Name +headerLabel _ CostHeader = Msg.get Msg.Payment_Cost +headerLabel _ UserHeader = Msg.get Msg.Payment_User +headerLabel _ CategoryHeader = Msg.get Msg.Payment_Category +headerLabel Punctual DateHeader = Msg.get Msg.Payment_Date +headerLabel Monthly DateHeader = "" + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> Frequency + -> Currency + -> Header + -> Payment + -> m () +cell users categories frequency currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + L.find ((== (_payment_category payment)) . _category_id) categories + in + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } + + DateHeader -> + if frequency == Punctual then + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment + else + R.blank diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs new file mode 100644 index 0000000..e68755f --- /dev/null +++ b/client/src/View/SignIn.hs @@ -0,0 +1,82 @@ +module View.SignIn + ( view + , Out(..) + ) where + +import qualified Data.Either as Either +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init, SignInForm (SignInForm)) +import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation + +import qualified Component.Button as Button +import qualified Component.Form as Form +import qualified Component.Input as Input +import qualified Util.Ajax as Ajax +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data Out t = Out + { _out_success :: Event t Init + } + +view :: forall t m. MonadWidget t m => m (Out t) +view = do + signInResult <- R.divClass "signIn" $ + Form.view $ do + rec + let resetForm = ("" <$ R.ffilter Either.isRight signInResult) + + email <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_EmailLabel + , Input._in_validation = SignInValidation.email + }) + resetForm + validate) + + password <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_PasswordLabel + , Input._in_validation = SignInValidation.password + , Input._in_inputType = "password" + }) + resetForm + validate) + + validate <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.SignIn_Button)) + { Button._in_class = R.constDyn "validate" + , Button._in_waiting = waiting + , Button._in_submit = True + }) + + let form = do + e <- email + p <- password + return . V.Success $ SignInForm e p + + (signInResult, waiting) <- WaitFor.waitFor + (Ajax.postAndParseResult "/api/signIn") + (ValidationUtil.fireValidation form validate) + + showSignInResult signInResult + + return signInResult + + return $ Out + { _out_success = R.filterRight signInResult + } + +showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m () +showSignInResult signInResult = do + _ <- R.widgetHold R.blank $ showResult <$> signInResult + R.blank + + where showResult (Left error) = R.divClass "error" . R.text $ error + showResult (Right _) = R.blank diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs new file mode 100644 index 0000000..63df2a1 --- /dev/null +++ b/client/src/View/Statistics/Chart.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} + +module View.Statistics.Chart + ( view + , In(..) + , Dataset(..) + ) where + +import qualified Control.Concurrent as Concurrent +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Map as M +import Data.Text (Text) +import Language.Javascript.JSaddle (JSString, JSVal) +import qualified Language.Javascript.JSaddle.Value as JSValue +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R +-- import GHCJS.Foreign.Callback + + +#ifdef __GHCJS__ +foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO () +#else +drawChart = error "drawChart: only available from JavaScript" +#endif + +data In = In + { _in_title :: Text + , _in_labels :: [Text] + , _in_datasets :: [Dataset] + } + +data Dataset = Dataset + { _dataset_label :: Text + , _dataset_data :: [Int] + , _dataset_color :: Text + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + R.divClass "g-Chart" $ + R.elAttr "canvas" (M.singleton "id" "chart") $ + R.blank + + liftIO $ Concurrent.forkIO $ do + Concurrent.threadDelay 500000 + config <- JSValue.valMakeJSON (configToJson input) + drawChart "chart" config + + return () + +configToJson (In title labels datasets) = + AE.object + [ "type" .= AE.String "line" + , "data" .= + AE.object + [ "labels" .= labels + , "datasets" .= map datasetToJson datasets + ] + , "options" .= + AE.object + [ "responsive" .= True + , "title" .= + AE.object + [ "display" .= True + , "text" .= title + ] + , "tooltips" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= False + ] + , "hover" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= True + ] + , "scales" .= + AE.object + [ "yAxes" .= + [ [ AE.object + [ "ticks" .= + AE.object + [ "beginAtZero" .= True ] + ] + ] + ] + ] + ] + ] + +datasetToJson (Dataset label data_ color) = + AE.object + [ "label" .= label + , "data" .= data_ + , "fill" .= False + , "backgroundColor" .= color + , "borderColor" .= color + ] diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs new file mode 100644 index 0000000..d931b2b --- /dev/null +++ b/client/src/View/Statistics/Statistics.hs @@ -0,0 +1,85 @@ +module View.Statistics.Statistics + ( view + , In(..) + ) where + +import Control.Monad (void) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Loadable (Loadable) +import qualified Loadable +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R +import qualified Util.Ajax as AjaxUtil +import qualified View.Statistics.Chart as Chart + +import Common.Model (Category (..), Currency, Income, + MonthStats (..), Stats, User (..)) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In = In + { _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + + users <- AjaxUtil.getNow "api/users" + categories <- AjaxUtil.getNow "api/allCategories" + statistics <- AjaxUtil.getNow "api/statistics" + + let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ Msg.get Msg.Statistics_Title + + void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $ + stats (_in_currency input) + +stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m () +stats currency (users, categories, stats) = + Chart.view $ Chart.In + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome) + , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats + , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories) + } + + where + averageIncome = + Format.price currency $ sum totalIncomes `div` length stats + + totalIncomeDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes + , Chart._dataset_data = totalIncomes + , Chart._dataset_color = "#222222" + } + + totalIncomes = + map (sum . map snd . M.toList . _monthStats_incomeByUser) stats + + averagePayment = + Format.price currency $ sum totalPayments `div` length stats + + totalPaymentDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments + , Chart._dataset_data = totalPayments + , Chart._dataset_color = "#555555" + } + + totalPayments = + map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats + + categoryDataset category = + Chart.Dataset + { Chart._dataset_label = _category_name category + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats + , Chart._dataset_color = _category_color category + } diff --git a/common/LICENSE b/common/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/common/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + <program> Copyright (C) <year> <name of author> + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +<http://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/common/Setup.hs b/common/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/common/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/common/common.cabal b/common/common.cabal new file mode 100644 index 0000000..dffc8d0 --- /dev/null +++ b/common/common.cabal @@ -0,0 +1,72 @@ +Name: common +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 + +Library + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + + Default-extensions: + DeriveGeneric + ExistentialQuantification + LambdaCase + MultiParamTypeClasses + OverloadedStrings + ScopedTypeVariables + + Build-depends: + aeson + , base >= 4.11 && < 5 + , containers + , text + , time + , validation + + Exposed-modules: + Common.Model + Common.Model.CreateCategoryForm + Common.Model.CreateIncomeForm + Common.Model.CreatePaymentForm + Common.Model.Email + Common.Model.Password + Common.Model.Payment + Common.Model.SignInForm + Common.Model.User + Common.Msg + Common.Util.Text + Common.Util.Time + Common.Util.Validation + Common.Validation.Atomic + Common.Validation.Category + Common.Validation.Income + Common.Validation.Payment + Common.Validation.SignIn + Common.View.Format + + other-modules: + Common.Message.Key + Common.Message.Lang + Common.Message.Translation + Common.Model.Category + Common.Model.CategoryPage + Common.Model.Currency + Common.Model.EditCategoryForm + Common.Model.EditIncome + Common.Model.EditIncomeForm + Common.Model.EditPaymentForm + Common.Model.ExceedingPayer + Common.Model.Frequency + Common.Model.Income + Common.Model.IncomeHeader + Common.Model.IncomePage + Common.Model.Init + Common.Model.PaymentHeader + Common.Model.PaymentPage + Common.Model.Stats diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs new file mode 100644 index 0000000..f3b0837 --- /dev/null +++ b/common/src/Common/Message/Key.hs @@ -0,0 +1,150 @@ +module Common.Message.Key + ( Key(..) + ) where + +import Data.Text + +data Key = + + App_Title + + | Category_Add + | Category_Clone + | Category_Color + | Category_DeleteConfirm + | Category_Edit + | Category_Empty + | Category_Name + | Category_NotDeleted + | Category_Title + | Category_Used + + | Date_Long Int Text Int + | Date_Short Int Int Int + | Date_ShortMonthAndYear Int Int + + | Dialog_Confirm + | Dialog_Undo + + | Error_CategoryCreate + | Error_CategoryDelete + | Error_CategoryEdit + | Error_IncomeCreate + | Error_IncomeDelete + | Error_IncomeEdit + | Error_PaymentCreate + | Error_PaymentDelete + | Error_PaymentEdit + | Error_SignOut + + | Form_AlreadyExists + | Form_NonEmpty + | Form_MinChars Int + | Form_NonNullNumber + | Form_GreaterIntThan Int + | Form_InvalidCategory + | Form_InvalidColor + | Form_InvalidDate + | Form_InvalidInt + | Form_InvalidString + | Form_SmallerIntThan Int + + | HttpError_BadPayload + | HttpError_BadUrl + | HttpError_NetworkError + | HttpError_Timeout + + | Income_AddLong + | Income_AddShort + | Income_Name + | Income_Amount + | Income_Clone + | Income_CumulativeSince Text + | Income_Date + | Income_DeleteConfirm + | Income_Edit + | Income_Empty + | Income_MonthlyNet + | Income_Title + + | Month_January + | Month_February + | Month_March + | Month_April + | Month_May + | Month_June + | Month_July + | Month_August + | Month_September + | Month_October + | Month_November + | Month_December + + | PageNotFound_Title + + | Payment_Add + | Payment_Balanced + | Payment_By Text Text + | Payment_Category + | Payment_CloneLong + | Payment_CloneShort + | Payment_Cost + | Payment_Date + | Payment_Delete + | Payment_DeleteConfirm + | Payment_EditLong + | Payment_EditShort + | Payment_Empty + | Payment_Frequency + | Payment_InvalidFrequency + | Payment_Many + | Payment_MonthlyFemale + | Payment_MonthlyMale + | Payment_Name + | Payment_NotDeleted + | Payment_One + | Payment_PunctualFemale + | Payment_PunctualMale + | Payment_Title + | Payment_User + | Payment_Worth Text Text + + | Search_Monthly + | Search_Name + | Search_Punctual + + | Secure_Forbidden + | Secure_Unauthorized + + | SignIn_Button + | SignIn_DisconnectSuccess + | SignIn_InvalidCredentials + | SignIn_EmailLabel + | SignIn_PasswordLabel + + | Statistics_Title + | Statistics_ByMonthsAndMean Text Text + | Statistics_TotalPayments + | Statistics_TotalIncomes + + | WeeklyReport_Empty + | WeeklyReport_IncomesCreated Int + | WeeklyReport_IncomesDeleted Int + | WeeklyReport_IncomesEdited Int + | WeeklyReport_IncomeCreated Int + | WeeklyReport_IncomeDeleted Int + | WeeklyReport_IncomeEdited Int + | WeeklyReport_PayedFor Text Text Text Text + | WeeklyReport_PayedForNot Text Text Text Text + | WeeklyReport_PayedFrom Text Text Text + | WeeklyReport_PayedFromNot Text Text Text + | WeeklyReport_PaymentsCreated Int + | WeeklyReport_PaymentsDeleted Int + | WeeklyReport_PaymentsEdited Int + | WeeklyReport_PaymentCreated Int + | WeeklyReport_PaymentDeleted Int + | WeeklyReport_PaymentEdited Int + | WeeklyReport_Title + + | NotFound_Message + | NotFound_LinkMessage diff --git a/common/src/Common/Message/Lang.hs b/common/src/Common/Message/Lang.hs new file mode 100644 index 0000000..0a32ede --- /dev/null +++ b/common/src/Common/Message/Lang.hs @@ -0,0 +1,7 @@ +module Common.Message.Lang + ( Lang(..) + ) where + +data Lang = + English + | French diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs new file mode 100644 index 0000000..222e669 --- /dev/null +++ b/common/src/Common/Message/Translation.hs @@ -0,0 +1,655 @@ +module Common.Message.Translation + ( get + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Common.Message.Key +import Common.Message.Lang (Lang (..)) + +get :: Lang -> Key -> Text +get = m + +m :: Lang -> Key -> Text + +m l App_Title = + case l of + English -> "Shared Cost" + French -> "Partage des frais" + +m l Category_Add = + case l of + English -> "Add an category" + French -> "Ajouter une catégorie" + +m l Category_Clone = + case l of + English -> "Clone an category" + French -> "Cloner une catégorie" + +m l Category_Color = + case l of + English -> "Color" + French -> "Couleur" + +m l Category_DeleteConfirm = + case l of + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" + +m l Category_Edit = + case l of + English -> "Edit an category" + French -> "Modifier une catégorie" + +m l Category_Empty = + case l of + English -> "No category." + French -> "Aucune catégorie." + +m l Category_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Category_NotDeleted = + case l of + English -> "The category could not have been deleted." + French -> "La catégorie n’a pas pu être supprimé." + +m l Category_Title = + case l of + English -> "Categories" + French -> "Catégories" + +m l Category_Used = + case l of + English -> "This category is currently being used" + French -> "Cette catégorie est actuellement utilisée" + +m l (Date_Short day month year) = + case l of + English -> + T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] + French -> + T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] + where padded num pad = + let str = show num + in T.pack $ replicate (pad - length str) '0' ++ str + +m l (Date_ShortMonthAndYear month year) = + case l of + English -> + T.intercalate "-" . map (T.pack . show) $ [ year, month ] + French -> + T.intercalate "/" . map (T.pack . show) $ [ month, year ] + +m l (Date_Long day month year) = + case l of + English -> + T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] + French -> + T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] + +m l Dialog_Confirm = + case l of + English -> "Confirm" + French -> "Confirmer" + +m l Dialog_Undo = + case l of + English -> "Undo" + French -> "Annuler" + +m l Error_CategoryCreate = + case l of + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" + +m l Error_CategoryDelete = + case l of + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" + +m l Error_CategoryEdit = + case l of + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" + +m l Error_IncomeCreate = + case l of + English -> "Error at income creation" + French -> "Erreur lors de la création du revenu" + +m l Error_IncomeDelete = + case l of + English -> "Error at income deletion" + French -> "Erreur lors de la suppression du revenu" + +m l Error_IncomeEdit = + case l of + English -> "Error at income edition" + French -> "Erreur lors de la modification du revenu" + +m l Error_PaymentCreate = + case l of + English -> "Error at payment creation" + French -> "Erreur lors de la création du paiement" + +m l Error_PaymentDelete = + case l of + English -> "Error at payment deletion" + French -> "Erreur lors de la suppression du paiement" + +m l Error_PaymentEdit = + case l of + English -> "Error at payment edition" + French -> "Erreur lors de la modification du paiement" + +m l Error_SignOut = + case l of + English -> "Error at sign out" + French -> "Erreur lors de la déconnexion" + +m l Form_AlreadyExists = + case l of + English -> "Dupplicate field" + French -> "Doublon" + +m l Form_NonEmpty = + case l of + English -> "Required field" + French -> "Champ requis" + +m l (Form_MinChars number) = + case l of + English -> T.concat [ "This field must contains at least ", T.pack . show $ number, " characters" ] + French -> T.concat [ "Ce champ doit contenir au moins ", T.pack . show $ number, " caractères" ] + +m l Form_NonNullNumber = + case l of + English -> "Number must not be null" + French -> "Le nombre ne doit pas être nul" + +m l (Form_GreaterIntThan number) = + case l of + English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] + +m l Form_InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + +m l Form_InvalidColor = + case l of + English -> "Invalid color" + French -> "Couleur invalide" + +m l Form_InvalidDate = + case l of + English -> "Date required" + French -> "Date requise" + +m l Form_InvalidInt = + case l of + English -> "Integer required" + French -> "Entier requis" + +m l Form_InvalidString = + case l of + English -> "String required" + French -> "Chaîne de caractères requise" + +m l (Form_SmallerIntThan number) = + case l of + English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] + +m l HttpError_BadPayload = + case l of + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" + +m l HttpError_BadUrl = + case l of + English -> "URL not valid" + French -> "l’URL n’est pas valide" + +m l HttpError_NetworkError = + case l of + English -> "Network can not be reached" + French -> "Le serveur n’est pas accessible" + +m l HttpError_Timeout = + case l of + English -> "Timeout server error" + French -> "Le serveur met trop de temps à répondre" + +m l Income_AddLong = + case l of + English -> "Add an income" + French -> "Ajouter un revenu" + +m l Income_AddShort = + case l of + English -> "Add" + French -> "Ajouter" + +m l Income_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Income_Amount = + case l of + English -> "Income" + French -> "Revenu" + +m l Income_Clone = + case l of + English -> "Clone an income" + French -> "Cloner un revenu" + +m l (Income_CumulativeSince since) = + case l of + English -> T.concat [ "Cumulative incomes since ", since ] + French -> T.concat [ "Revenus nets cumulés depuis le ", since ] + +m l Income_Date = + case l of + English -> "Date" + French -> "Date" + +m l Income_DeleteConfirm = + case l of + English -> "Are you sure to delete this income ?" + French -> "Voulez-vous vraiment supprimer ce revenu ?" + +m l Income_Edit = + case l of + English -> "Edit an income" + French -> "Modifier un revenu" + +m l Income_Empty = + case l of + English -> "No income." + French -> "Aucun revenu." + +m l Income_MonthlyNet = + case l of + English -> "Net monthly incomes" + French -> "Revenus mensuels nets" + +m l Income_Title = + case l of + English -> "Income" + French -> "Revenu" + +m l Month_January = + case l of + English -> "january" + French -> "janvier" + +m l Month_February = + case l of + English -> "february" + French -> "février" + +m l Month_March = + case l of + English -> "march" + French -> "mars" + +m l Month_April = + case l of + English -> "april" + French -> "avril" + +m l Month_May = + case l of + English -> "may" + French -> "mai" + +m l Month_June = + case l of + English -> "june" + French -> "juin" + +m l Month_July = + case l of + English -> "july" + French -> "juillet" + +m l Month_August = + case l of + English -> "august" + French -> "août" + +m l Month_September = + case l of + English -> "september" + French -> "septembre" + +m l Month_October = + case l of + English -> "october" + French -> "octobre" + +m l Month_November = + case l of + English -> "november" + French -> "novembre" + +m l Month_December = + case l of + English -> "december" + French -> "décembre" + +m l PageNotFound_Title = + case l of + English -> "Page not found" + French -> "Page introuvable" + +m l Payment_Add = + case l of + English -> "Add a payment" + French -> "Ajouter un paiement" + +m l Payment_Balanced = + case l of + English -> "Payments are balanced." + French -> "Les paiements sont équilibrés." + +m l (Payment_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + +m l Payment_Category = + case l of + English -> "Category" + French -> "Catégorie" + +m l Payment_CloneLong = + case l of + English -> "Clone a payment" + French -> "Cloner un paiement" + +m l Payment_CloneShort = + case l of + English -> "Clone" + French -> "Cloner" + +m l Payment_Cost = + case l of + English -> "Cost" + French -> "Coût" + +m l Payment_Date = + case l of + English -> "Date" + French -> "Date" + +m l Payment_Delete = + case l of + English -> "Delete" + French -> "Supprimer" + +m l Payment_DeleteConfirm = + case l of + English -> "Are you sure to delete this payment ?" + French -> "Voulez-vous vraiment supprimer ce paiement ?" + +m l Payment_EditLong = + case l of + English -> "Edit a payment" + French -> "Modifier un paiement" + +m l Payment_EditShort = + case l of + English -> "Edit" + French -> "Modifier" + +m l Payment_Empty = + case l of + English -> "No payment found from your search criteria." + French -> "Aucun paiement ne correspond à vos critères de recherches." + +m l Payment_Frequency = + case l of + English -> "Frequency" + French -> "Fréquence" + +m l Payment_InvalidFrequency = + case l of + English -> "Invalid frequency" + French -> "Fréquence invalide" + +m l Payment_Many = + case l of + English -> "payments" + French -> "paiements" + +m l Payment_MonthlyFemale = + case l of + English -> "Monthly" + French -> "Mensuelle" + +m l Payment_MonthlyMale = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Payment_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Payment_NotDeleted = + case l of + English -> "The payment could not have been deleted." + French -> "Le paiement n’a pas pu être supprimé." + +m l Payment_One = + case l of + English -> "payment" + French -> "paiement" + +m l Payment_PunctualFemale = + case l of + English -> "Punctual" + French -> "Ponctuelle" + +m l Payment_PunctualMale = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Payment_Title = + case l of + English -> "Payments" + French -> "Paiements" + +m l Payment_User = + case l of + English -> "Payer" + French -> "Payeur" + +m l (Payment_Worth subject amount) = + case l of + English -> T.concat [ subject, " worth ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] + +m l Search_Monthly = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Search_Name = + case l of + English -> "Search" + French -> "Recherche" + +m l Search_Punctual = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Secure_Unauthorized = + case l of + English -> "You are not authorized to sign in." + French -> "Tu n’es pas autorisé à te connecter." + +m l Secure_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 SignIn_Button = + case l of + English -> "Sign in" + French -> "Connexion" + +m l SignIn_DisconnectSuccess = + case l of + English -> "You have successfully disconnected" + French -> "Vous êtes à présent déconnecté." + +m l SignIn_InvalidCredentials = + case l of + English -> "Your credentials are not valid." + French -> "Vos identifiants de connexion ne sont pas valides." + +m l SignIn_EmailLabel = + case l of + English -> "Email" + French -> "Courriel" + +m l SignIn_PasswordLabel = + case l of + English -> "Password" + French -> "Mot de passe" + +m l (Statistics_ByMonthsAndMean paymentMean incomeMean ) = + case l of + English -> + T.concat [ "Payments by category (mean ", paymentMean, ") and income (mean ", incomeMean, ") by month" ] + French -> + T.concat [ "Paiements par catégorie (moy. ", paymentMean, ") et revenu (moy. ", incomeMean, ") par mois" ] + +m l Statistics_Title = + case l of + English -> "Statistics" + French -> "Statistiques" + +m l Statistics_TotalPayments = + case l of + English -> "Payment total" + French -> "Total des paiements" + +m l Statistics_TotalIncomes = + case l of + English -> "Income total" + French -> "Total des revenus" + +m l WeeklyReport_Empty = + case l of + English -> "No activity the previous week." + French -> "Pas d’activité la semaine passée." + +m l (WeeklyReport_IncomesCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes created:" ] + French -> T.concat [ T.pack . show $ count, " revenus créés :" ] + +m l (WeeklyReport_IncomesDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] + +m l (WeeklyReport_IncomesEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes edited:" ] + French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] + +m l (WeeklyReport_IncomeCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " income created:" ] + French -> T.concat [ T.pack . show $ count, " revenu créé :" ] + +m l (WeeklyReport_IncomeDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " income deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] + +m l (WeeklyReport_IncomeEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " income edited:" ] + French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] + +m l (WeeklyReport_PayedFor name amount for at) = + case l of + English -> T.concat [ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ name, " a payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedForNot name amount for at) = + case l of + English -> T.concat [ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedFrom name amount for) = + case l of + English -> T.concat [ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ name, " est payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PayedFromNot name amount for) = + case l of + English -> T.concat [ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PaymentsCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments created:" ] + French -> T.concat [ T.pack . show $ count, " paiements créés :" ] + +m l (WeeklyReport_PaymentsDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] + +m l (WeeklyReport_PaymentsEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments edited:" ] + French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] + +m l (WeeklyReport_PaymentCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment created:" ] + French -> T.concat [ T.pack . show $ count, " paiement créé :" ] + +m l (WeeklyReport_PaymentDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] + +m l (WeeklyReport_PaymentEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment edited:" ] + French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] + +m l WeeklyReport_Title = + case l of + English -> "Weekly report" + French -> "Rapport hebdomadaire" + +m l NotFound_Message = + case l of + English -> "There is nothing here!" + French -> "Il n’y a rien à voir ici." + +m l NotFound_LinkMessage = + case l of + English -> "Go back to the home page." + French -> "Retour à l’accueil." diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs new file mode 100644 index 0000000..979d876 --- /dev/null +++ b/common/src/Common/Model.hs @@ -0,0 +1,26 @@ +module Common.Model (module X) where + +import Common.Model.Category as X +import Common.Model.CategoryPage as X +import Common.Model.CreateCategoryForm as X +import Common.Model.CreateIncomeForm as X +import Common.Model.CreatePaymentForm as X +import Common.Model.Currency as X +import Common.Model.EditCategoryForm as X +import Common.Model.EditIncome as X +import Common.Model.EditIncomeForm as X +import Common.Model.EditPaymentForm as X +import Common.Model.Email as X +import Common.Model.ExceedingPayer as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.IncomeHeader as X +import Common.Model.IncomePage as X +import Common.Model.Init as X +import Common.Model.Password as X +import Common.Model.Payment as X +import Common.Model.PaymentHeader as X +import Common.Model.PaymentPage as X +import Common.Model.SignInForm as X +import Common.Model.Stats as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs new file mode 100644 index 0000000..cc3f795 --- /dev/null +++ b/common/src/Common/Model/Category.hs @@ -0,0 +1,24 @@ +module Common.Model.Category + ( CategoryId + , Category(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type CategoryId = Int64 + +data Category = Category + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text + , _category_createdAt :: UTCTime + , _category_editedAt :: Maybe UTCTime + , _category_deletedAt :: Maybe UTCTime + } deriving (Eq, Show, Generic) + +instance FromJSON Category +instance ToJSON Category diff --git a/common/src/Common/Model/CategoryPage.hs b/common/src/Common/Model/CategoryPage.hs new file mode 100644 index 0000000..e20f49f --- /dev/null +++ b/common/src/Common/Model/CategoryPage.hs @@ -0,0 +1,18 @@ +module Common.Model.CategoryPage + ( CategoryPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category, CategoryId) + +data CategoryPage = CategoryPage + { _categoryPage_page :: Int + , _categoryPage_categories :: [Category] + , _categoryPage_usedCategories :: [CategoryId] + , _categoryPage_totalCount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON CategoryPage +instance ToJSON CategoryPage diff --git a/common/src/Common/Model/CreateCategoryForm.hs b/common/src/Common/Model/CreateCategoryForm.hs new file mode 100644 index 0000000..4668ef4 --- /dev/null +++ b/common/src/Common/Model/CreateCategoryForm.hs @@ -0,0 +1,15 @@ +module Common.Model.CreateCategoryForm + ( CreateCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategoryForm = CreateCategoryForm + { _createCategoryForm_name :: Text + , _createCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategoryForm +instance ToJSON CreateCategoryForm diff --git a/common/src/Common/Model/CreateIncomeForm.hs b/common/src/Common/Model/CreateIncomeForm.hs new file mode 100644 index 0000000..e83bf0a --- /dev/null +++ b/common/src/Common/Model/CreateIncomeForm.hs @@ -0,0 +1,15 @@ +module Common.Model.CreateIncomeForm + ( CreateIncomeForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateIncomeForm = CreateIncomeForm + { _createIncomeForm_amount :: Text + , _createIncomeForm_date :: Text + } deriving (Show, Generic) + +instance FromJSON CreateIncomeForm +instance ToJSON CreateIncomeForm diff --git a/common/src/Common/Model/CreatePaymentForm.hs b/common/src/Common/Model/CreatePaymentForm.hs new file mode 100644 index 0000000..60c5423 --- /dev/null +++ b/common/src/Common/Model/CreatePaymentForm.hs @@ -0,0 +1,21 @@ +module Common.Model.CreatePaymentForm + ( CreatePaymentForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePaymentForm = CreatePaymentForm + { _createPaymentForm_name :: Text + , _createPaymentForm_cost :: Text + , _createPaymentForm_date :: Text + , _createPaymentForm_category :: CategoryId + , _createPaymentForm_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePaymentForm +instance ToJSON CreatePaymentForm diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs new file mode 100644 index 0000000..175aeba --- /dev/null +++ b/common/src/Common/Model/Currency.hs @@ -0,0 +1,12 @@ +module Common.Model.Currency + ( Currency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Currency = Currency Text deriving (Show, Generic) + +instance FromJSON Currency +instance ToJSON Currency diff --git a/common/src/Common/Model/EditCategoryForm.hs b/common/src/Common/Model/EditCategoryForm.hs new file mode 100644 index 0000000..a2ceca0 --- /dev/null +++ b/common/src/Common/Model/EditCategoryForm.hs @@ -0,0 +1,18 @@ +module Common.Model.EditCategoryForm + ( EditCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategoryForm = EditCategoryForm + { _editCategoryForm_id :: CategoryId + , _editCategoryForm_name :: Text + , _editCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategoryForm +instance ToJSON EditCategoryForm diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs new file mode 100644 index 0000000..0e65f12 --- /dev/null +++ b/common/src/Common/Model/EditIncome.hs @@ -0,0 +1,17 @@ +module Common.Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_date :: Day + , _editIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON EditIncome diff --git a/common/src/Common/Model/EditIncomeForm.hs b/common/src/Common/Model/EditIncomeForm.hs new file mode 100644 index 0000000..ff975fc --- /dev/null +++ b/common/src/Common/Model/EditIncomeForm.hs @@ -0,0 +1,18 @@ +module Common.Model.EditIncomeForm + ( EditIncomeForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncomeForm = EditIncomeForm + { _editIncomeForm_id :: IncomeId + , _editIncomeForm_amount :: Text + , _editIncomeForm_date :: Text + } deriving (Show, Generic) + +instance FromJSON EditIncomeForm +instance ToJSON EditIncomeForm diff --git a/common/src/Common/Model/EditPaymentForm.hs b/common/src/Common/Model/EditPaymentForm.hs new file mode 100644 index 0000000..168c9ff --- /dev/null +++ b/common/src/Common/Model/EditPaymentForm.hs @@ -0,0 +1,23 @@ +module Common.Model.EditPaymentForm + ( EditPaymentForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPaymentForm = EditPaymentForm + { _editPaymentForm_id :: PaymentId + , _editPaymentForm_name :: Text + , _editPaymentForm_cost :: Text + , _editPaymentForm_date :: Text + , _editPaymentForm_category :: CategoryId + , _editPaymentForm_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPaymentForm +instance ToJSON EditPaymentForm diff --git a/common/src/Common/Model/Email.hs b/common/src/Common/Model/Email.hs new file mode 100644 index 0000000..e938f83 --- /dev/null +++ b/common/src/Common/Model/Email.hs @@ -0,0 +1,12 @@ +module Common.Model.Email + ( Email(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Email = Email Text deriving (Show, Generic) + +instance FromJSON Email +instance ToJSON Email diff --git a/common/src/Common/Model/ExceedingPayer.hs b/common/src/Common/Model/ExceedingPayer.hs new file mode 100644 index 0000000..b7d3efb --- /dev/null +++ b/common/src/Common/Model/ExceedingPayer.hs @@ -0,0 +1,16 @@ +module Common.Model.ExceedingPayer + ( ExceedingPayer(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON ExceedingPayer +instance ToJSON ExceedingPayer diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs new file mode 100644 index 0000000..48e75ea --- /dev/null +++ b/common/src/Common/Model/Frequency.hs @@ -0,0 +1,14 @@ +module Common.Model.Frequency + ( Frequency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Frequency = + Punctual + | Monthly + deriving (Eq, Read, Show, Generic, Ord) + +instance FromJSON Frequency +instance ToJSON Frequency diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs new file mode 100644 index 0000000..57d07f1 --- /dev/null +++ b/common/src/Common/Model/Income.hs @@ -0,0 +1,27 @@ +module Common.Model.Income + ( IncomeId + , Income(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +type IncomeId = Int64 + +data Income = Income + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int + , _income_createdAt :: UTCTime + , _income_editedAt :: Maybe UTCTime + , _income_deletedAt :: Maybe UTCTime + } deriving (Eq, Show, Generic) + +instance FromJSON Income +instance ToJSON Income diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs new file mode 100644 index 0000000..7e712e8 --- /dev/null +++ b/common/src/Common/Model/IncomeHeader.hs @@ -0,0 +1,18 @@ +module Common.Model.IncomeHeader + ( IncomeHeader(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +data IncomeHeader = IncomeHeader + { _incomeHeader_since :: Maybe Day + , _incomeHeader_byUser :: Map UserId Int + } deriving (Eq, Show, Generic) + +instance FromJSON IncomeHeader +instance ToJSON IncomeHeader diff --git a/common/src/Common/Model/IncomePage.hs b/common/src/Common/Model/IncomePage.hs new file mode 100644 index 0000000..977b0ea --- /dev/null +++ b/common/src/Common/Model/IncomePage.hs @@ -0,0 +1,19 @@ +module Common.Model.IncomePage + ( IncomePage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Income (Income) +import Common.Model.IncomeHeader (IncomeHeader) + +data IncomePage = IncomePage + { _incomePage_page :: Int + , _incomePage_header :: IncomeHeader + , _incomePage_incomes :: [Income] + , _incomePage_totalCount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON IncomePage +instance ToJSON IncomePage diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs new file mode 100644 index 0000000..5ef1535 --- /dev/null +++ b/common/src/Common/Model/Init.hs @@ -0,0 +1,18 @@ +module Common.Model.Init + ( Init(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Currency (Currency) +import Common.Model.User (User, UserId) + +data Init = Init + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_currency :: Currency + } deriving (Show, Generic) + +instance FromJSON Init +instance ToJSON Init diff --git a/common/src/Common/Model/Password.hs b/common/src/Common/Model/Password.hs new file mode 100644 index 0000000..1b51a47 --- /dev/null +++ b/common/src/Common/Model/Password.hs @@ -0,0 +1,12 @@ +module Common.Model.Password + ( Password(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Password = Password Text deriving (Show, Generic) + +instance FromJSON Password +instance ToJSON Password diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs new file mode 100644 index 0000000..733a145 --- /dev/null +++ b/common/src/Common/Model/Payment.hs @@ -0,0 +1,33 @@ +module Common.Model.Payment + ( PaymentId + , Payment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency +import Common.Model.User (UserId) + +type PaymentId = Int64 + +data Payment = Payment + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day + , _payment_category :: CategoryId + , _payment_frequency :: Frequency + , _payment_createdAt :: UTCTime + , _payment_editedAt :: Maybe UTCTime + , _payment_deletedAt :: Maybe UTCTime + } deriving (Eq, Show, Generic) + +instance FromJSON Payment +instance ToJSON Payment diff --git a/common/src/Common/Model/PaymentHeader.hs b/common/src/Common/Model/PaymentHeader.hs new file mode 100644 index 0000000..35f5e1a --- /dev/null +++ b/common/src/Common/Model/PaymentHeader.hs @@ -0,0 +1,18 @@ +module Common.Model.PaymentHeader + ( PaymentHeader(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import GHC.Generics (Generic) + +import Common.Model.ExceedingPayer (ExceedingPayer) +import Common.Model.User (UserId) + +data PaymentHeader = PaymentHeader + { _paymentHeader_exceedingPayers :: [ExceedingPayer] + , _paymentHeader_repartition :: Map UserId Int + } deriving (Eq, Show, Generic) + +instance FromJSON PaymentHeader +instance ToJSON PaymentHeader diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs new file mode 100644 index 0000000..88d9715 --- /dev/null +++ b/common/src/Common/Model/PaymentPage.hs @@ -0,0 +1,21 @@ +module Common.Model.PaymentPage + ( PaymentPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (Payment) +import Common.Model.PaymentHeader (PaymentHeader) + +data PaymentPage = PaymentPage + { _paymentPage_page :: Int + , _paymentPage_frequency :: Frequency + , _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] + , _paymentPage_totalCount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON PaymentPage +instance ToJSON PaymentPage diff --git a/common/src/Common/Model/SignInForm.hs b/common/src/Common/Model/SignInForm.hs new file mode 100644 index 0000000..7a25935 --- /dev/null +++ b/common/src/Common/Model/SignInForm.hs @@ -0,0 +1,15 @@ +module Common.Model.SignInForm + ( SignInForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignInForm = SignInForm + { _signInForm_email :: Text + , _signInForm_password :: Text + } deriving (Show, Generic) + +instance FromJSON SignInForm +instance ToJSON SignInForm diff --git a/common/src/Common/Model/Stats.hs b/common/src/Common/Model/Stats.hs new file mode 100644 index 0000000..86e6ab9 --- /dev/null +++ b/common/src/Common/Model/Stats.hs @@ -0,0 +1,23 @@ +module Common.Model.Stats + ( Stats + , MonthStats(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.User (UserId) + +type Stats = [MonthStats] + +data MonthStats = MonthStats + { _monthStats_start :: Day + , _monthStats_paymentsByCategory :: Map CategoryId Int + , _monthStats_incomeByUser :: Map UserId Int + } deriving (Eq, Show, Generic) + +instance FromJSON MonthStats +instance ToJSON MonthStats diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs new file mode 100644 index 0000000..a30d104 --- /dev/null +++ b/common/src/Common/Model/User.hs @@ -0,0 +1,27 @@ +module Common.Model.User + ( UserId + , User(..) + , findUser + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import qualified Data.List as L +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type UserId = Int64 + +data User = User + { _user_id :: UserId + , _user_creation :: UTCTime + , _user_email :: Text + , _user_name :: Text + } deriving (Show, Generic) + +instance FromJSON User +instance ToJSON User + +findUser :: UserId -> [User] -> Maybe User +findUser userId users = L.find ((== userId) . _user_id) users diff --git a/common/src/Common/Msg.hs b/common/src/Common/Msg.hs new file mode 100644 index 0000000..9e4cfe2 --- /dev/null +++ b/common/src/Common/Msg.hs @@ -0,0 +1,13 @@ +module Common.Msg + ( get + , Key(..) + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key (..)) +import Common.Message.Lang (Lang (..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/src/server/Utils/Text.hs b/common/src/Common/Util/Text.hs index 5ed77e4..0f9c187 100644 --- a/src/server/Utils/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,10 +1,18 @@ -module Utils.Text - ( unaccent +module Common.Util.Text + ( search + , formatSearch + , unaccent ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T +search :: Text -> Text -> Bool +search s t = (formatSearch s) `T.isInfixOf` (formatSearch t) + +formatSearch :: Text -> Text +formatSearch = T.toLower . unaccent + unaccent :: Text -> Text unaccent = T.map unaccentChar @@ -38,4 +46,4 @@ unaccentChar c = case c of 'ý' -> 'y' 'ÿ' -> 'y' 'ž' -> 'z' - _ -> c + _ -> c diff --git a/common/src/Common/Util/Time.hs b/common/src/Common/Util/Time.hs new file mode 100644 index 0000000..6240720 --- /dev/null +++ b/common/src/Common/Util/Time.hs @@ -0,0 +1,26 @@ +module Common.Util.Time + ( timeToDay + , parseDay + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) +import Data.Time.LocalTime +import qualified Text.Read as T + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time + +parseDay :: Text -> Maybe Day +parseDay str = do + (y, m, d) <- + case T.splitOn "-" str of + [y, m, d] -> Just (y, m, d) + _ -> Nothing + d' <- T.readMaybe . T.unpack $ d + m' <- T.readMaybe . T.unpack $ m + y' <- T.readMaybe . T.unpack $ y + return $ Time.fromGregorian y' m' d' diff --git a/common/src/Common/Util/Validation.hs b/common/src/Common/Util/Validation.hs new file mode 100644 index 0000000..f195d95 --- /dev/null +++ b/common/src/Common/Util/Validation.hs @@ -0,0 +1,13 @@ +module Common.Util.Validation + ( isSuccess + , isFailure + ) where + +import Data.Validation (Validation (Failure, Success)) + +isSuccess :: forall a b. Validation a b -> Bool +isSuccess (Failure _) = False +isSuccess (Success _) = True + +isFailure :: forall a b. Validation a b -> Bool +isFailure = not . isSuccess diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs new file mode 100644 index 0000000..9c21e14 --- /dev/null +++ b/common/src/Common/Validation/Atomic.hs @@ -0,0 +1,61 @@ +module Common.Validation.Atomic + ( color + , day + , minLength + , nonEmpty + , nonNullNumber + , number + , password + ) where + +import qualified Data.Char as Char +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V +import qualified Text.Read as T + +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time + +minLength :: Int -> Text -> Validation Text Text +minLength l = + V.validate + (Msg.get (Msg.Form_MinChars l)) + (\t -> if T.length t >= l then Just t else Nothing) + +nonEmpty :: Text -> Validation Text Text +nonEmpty = + V.validate + (Msg.get Msg.Form_NonEmpty) + (\t -> if (not . T.null $ t) then Just t else Nothing) + +number :: Text -> Validation Text Int +number input = + case (T.readMaybe . T.unpack $ input) of + Just n -> V.Success n + _ -> V.Failure (Msg.get Msg.Form_InvalidInt) + +nonNullNumber :: Int -> Validation Text Int +nonNullNumber = + V.validate + (Msg.get Msg.Form_NonNullNumber) + (\n -> if n /= 0 then Just n else Nothing) + +day :: Text -> Validation Text Day +day str = + case Time.parseDay str of + Just d -> V.Success d + Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate + +color :: Text -> Validation Text Text +color str = + if T.take 1 str == "#" && T.all Char.isHexDigit (T.drop 1 str) then + V.Success str + + else + V.Failure (Msg.get Msg.Form_InvalidColor) + +password :: Text -> Validation Text Text +password = minLength 8 diff --git a/common/src/Common/Validation/Category.hs b/common/src/Common/Validation/Category.hs new file mode 100644 index 0000000..f9e6ab4 --- /dev/null +++ b/common/src/Common/Validation/Category.hs @@ -0,0 +1,15 @@ +module Common.Validation.Category + ( name + , color + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import qualified Common.Validation.Atomic as Atomic + +name :: Text -> Validation Text Text +name = Atomic.nonEmpty + +color :: Text -> Validation Text Text +color = Atomic.color diff --git a/common/src/Common/Validation/Income.hs b/common/src/Common/Validation/Income.hs new file mode 100644 index 0000000..7a58bab --- /dev/null +++ b/common/src/Common/Validation/Income.hs @@ -0,0 +1,17 @@ +module Common.Validation.Income + ( amount + , date + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import qualified Common.Validation.Atomic as Atomic + +amount :: Text -> Validation Text Int +amount input = V.bindValidation (Atomic.number input) Atomic.nonNullNumber + +date :: Text -> Validation Text Day +date = Atomic.day diff --git a/common/src/Common/Validation/Payment.hs b/common/src/Common/Validation/Payment.hs new file mode 100644 index 0000000..e3c447a --- /dev/null +++ b/common/src/Common/Validation/Payment.hs @@ -0,0 +1,31 @@ +module Common.Validation.Payment + ( name + , cost + , date + , category + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CategoryId) +import qualified Common.Msg as Msg +import qualified Common.Validation.Atomic as Atomic + +name :: Text -> Validation Text Text +name = Atomic.nonEmpty + +cost :: Text -> Validation Text Int +cost input = V.bindValidation (Atomic.number input) Atomic.nonNullNumber + +date :: Text -> Validation Text Day +date = Atomic.day + +category :: [CategoryId] -> CategoryId -> Validation Text CategoryId +category cs c = + if elem c cs then + V.Success c + else + V.Failure $ Msg.get Msg.Form_InvalidCategory diff --git a/common/src/Common/Validation/SignIn.hs b/common/src/Common/Validation/SignIn.hs new file mode 100644 index 0000000..ac9cc37 --- /dev/null +++ b/common/src/Common/Validation/SignIn.hs @@ -0,0 +1,17 @@ +module Common.Validation.SignIn + ( email + , password + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model.Email (Email (..)) +import Common.Model.Password (Password (..)) +import qualified Common.Validation.Atomic as Atomic + +email :: Text -> Validation Text Email +email = fmap Email . Atomic.minLength 5 + +password :: Text -> Validation Text Password +password = fmap Password . Atomic.minLength 8 diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs new file mode 100644 index 0000000..5d879fa --- /dev/null +++ b/common/src/Common/View/Format.hs @@ -0,0 +1,78 @@ +module Common.View.Format + ( shortDay + , longDay + , price + , number + , monthAndYear + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar + +import Common.Model (Currency (..)) +import Common.Msg (Key) +import qualified Common.Msg as Msg + +shortDay :: Day -> Text +shortDay date = + Msg.get $ Msg.Date_Short + day + month + (fromIntegral year) + where (year, month, day) = Calendar.toGregorian date + +longDay :: Day -> Text +longDay date = + Msg.get $ Msg.Date_Long + day + (Maybe.fromMaybe "−" . fmap Msg.get . monthToKey $ month) + (fromIntegral year) + where (year, month, day) = Calendar.toGregorian date + +monthAndYear :: Day -> Text +monthAndYear date = + T.intercalate " " + [ Maybe.fromMaybe "" . fmap ((\t -> T.concat [t, " "]) . Msg.get) . monthToKey $ month + , T.pack . show $ year + ] + where (year, month, _) = Calendar.toGregorian date + +monthToKey :: Int -> Maybe Key +monthToKey 1 = Just Msg.Month_January +monthToKey 2 = Just Msg.Month_February +monthToKey 3 = Just Msg.Month_March +monthToKey 4 = Just Msg.Month_April +monthToKey 5 = Just Msg.Month_May +monthToKey 6 = Just Msg.Month_June +monthToKey 7 = Just Msg.Month_July +monthToKey 8 = Just Msg.Month_August +monthToKey 9 = Just Msg.Month_September +monthToKey 10 = Just Msg.Month_October +monthToKey 11 = Just Msg.Month_November +monthToKey 12 = Just Msg.Month_December +monthToKey _ = Nothing + +price :: Currency -> Int -> Text +price (Currency currency) amount = T.concat [ number amount, " ", currency ] + +number :: Int -> Text +number n = + T.pack + . (++) (if n < 0 then "-" else "") + . reverse + . concat + . L.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/default.nix b/default.nix new file mode 100644 index 0000000..7969fc7 --- /dev/null +++ b/default.nix @@ -0,0 +1,25 @@ +with import <nixpkgs> {}; + +let + reflex-platform = import (pkgs.fetchFromGitHub { + owner = "reflex-frp"; + repo = "reflex-platform"; + + # Mon Jul 29 15:48:55 2019 -0400 + rev = "51e02339704b7502e63bccf10a72fa4dda744b17"; + sha256 = "1mkimidf755968xzbm3z222xgpdvgg6xmmrfppv1hw0rap5w53iw"; + }) {}; +in + reflex-platform.project ({ pkgs, ... }: { + packages = { + validation = ./validation; + common = ./common; + server = ./server; + client = ./client; + }; + + shells = { + ghc = [ "validation" "common" "server" ]; + ghcjs = [ "validation" "common" "client" ]; + }; + }) diff --git a/elm-package.json b/elm-package.json deleted file mode 100644 index 9f7fcbf..0000000 --- a/elm-package.json +++ /dev/null @@ -1,26 +0,0 @@ -{ - "version": "0.0.1", - "summary": "SharedCost", - "repository": "https://github.com/guyonvarch/sharedcost.git", - "license": "GPL-3", - "source-directories": [ "src/client" ], - "exposed-modules": [], - "elm-version": "0.18.0 <= v < 0.19.0", - "dependencies": { - "elm-community/json-extra": "2.1.0 <= v < 3.0.0", - "elm-community/list-extra": "6.0.0 <= v < 7.0.0", - "elm-community/maybe-extra": "4.0.0 <= v < 5.0.0", - "elm-lang/core": "5.1.1 <= v < 6.0.0", - "elm-lang/dom": "1.1.1 <= v < 2.0.0", - "elm-lang/html": "2.0.0 <= v < 3.0.0", - "elm-lang/http": "1.0.0 <= v < 2.0.0", - "elm-lang/mouse": "1.0.1 <= v < 2.0.0", - "elm-lang/navigation": "2.0.1 <= v < 3.0.0", - "elm-lang/svg": "2.0.0 <= v < 3.0.0", - "elm-lang/window": "1.0.1 <= v < 2.0.0", - "etaque/elm-form": "2.0.0 <= v < 3.0.0", - "evancz/url-parser": "2.0.1 <= v < 3.0.0", - "jystic/elm-font-awesome": "2.0.1 <= v < 3.0.0", - "rluiten/elm-date-extra": "8.3.0 <= v < 9.0.0" - } -} diff --git a/public/css/reset.css b/public/css/reset.css index 42f3b8c..2eecc94 100644 --- a/public/css/reset.css +++ b/public/css/reset.css @@ -56,17 +56,5 @@ button:hover { cursor: pointer; } button::-moz-focus-inner { border: 0; } :focus { outline: none; } -select:-moz-focusring { - color: transparent; - text-shadow: 0 0 0 #000; -} -select { - -webkit-appearance: none; - -moz-appearance: none; - text-indent: 1px; - text-overflow: ''; - cursor: pointer; -} - html { box-sizing: border-box; } *, *:before, *:after { box-sizing: inherit; } diff --git a/public/javascripts/.gitkeep b/public/javascript/.gitkeep index e69de29..e69de29 100644 --- a/public/javascripts/.gitkeep +++ b/public/javascript/.gitkeep diff --git a/public/javascripts/main.js b/public/javascripts/main.js deleted file mode 100644 index 3c3d797..0000000 --- a/public/javascripts/main.js +++ /dev/null @@ -1,17 +0,0 @@ -// Remove search query -window.history.pushState( - { - html: document.documentElement.innerHTML, - pageTitle: document.title - }, - '', - document.location.pathname + document.location.hash -); - -var app = Elm.Main.fullscreen({ - time: new Date().getTime(), - translations: JSON.parse(document.getElementById('translations').innerHTML), - conf: JSON.parse(document.getElementById('conf').innerHTML), - result: JSON.parse(document.getElementById('result').innerHTML), - windowSize: { width: window.innerWidth, height: window.innerHeight } -}); diff --git a/server/LICENSE b/server/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/server/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + <program> Copyright (C) <year> <name of author> + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +<http://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/server/Setup.hs b/server/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/migrations/1.sql b/server/migrations/1.sql index d7c300e..d7c300e 100644 --- a/src/migrations/1.sql +++ b/server/migrations/1.sql diff --git a/server/migrations/2.sql b/server/migrations/2.sql new file mode 100644 index 0000000..c1d502f --- /dev/null +++ b/server/migrations/2.sql @@ -0,0 +1,44 @@ +-- Add payment categories with accents from payment with accents + +INSERT INTO + payment_category (name, category, created_at) +SELECT + DISTINCT lower(payment.name), payment_category.category, datetime('now') +FROM + payment +INNER JOIN + payment_category +ON + replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(payment.name), 'é', 'e'), 'è', 'e'), 'à', 'a'), 'û', 'u'), 'â', 'a'), 'ê', 'e'), 'â', 'a'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ë', 'e') = payment_category.name +WHERE + payment.name +IN + (SELECT DISTINCT payment.name FROM payment WHERE lower(payment.name) NOT IN (SELECT payment_category.name FROM payment_category) AND payment.deleted_at IS NULL); + +-- Remove unused payment categories + +DELETE FROM + payment_category +WHERE + name NOT IN (SELECT DISTINCT lower(name) FROM payment); + +-- Add category id to payment table + +PRAGMA foreign_keys = 0; + +ALTER TABLE payment ADD COLUMN "category" INTEGER NOT NULL REFERENCES "category" DEFAULT -1; + +PRAGMA foreign_keys = 1; + +UPDATE + payment +SET + category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) +WHERE + EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)); + +DELETE FROM payment WHERE category = -1; + +-- Remove + +DROP TABLE payment_category; diff --git a/server/migrations/3.sql b/server/migrations/3.sql new file mode 100644 index 0000000..a3d8a13 --- /dev/null +++ b/server/migrations/3.sql @@ -0,0 +1,5 @@ +DROP TABLE sign_in; + +ALTER TABLE user ADD COLUMN "password" TEXT NOT NULL DEFAULT "password"; + +ALTER TABLE user ADD COLUMN "sign_in_token" TEXT NULL; diff --git a/server/server.cabal b/server/server.cabal new file mode 100644 index 0000000..5427385 --- /dev/null +++ b/server/server.cabal @@ -0,0 +1,131 @@ +Name: server +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 + +Executable server + Main-is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + + Default-extensions: + ExistentialQuantification + LambdaCase + MultiParamTypeClasses + OverloadedStrings + ScopedTypeVariables + + Build-depends: + aeson + , base >= 4.11 && < 5 + , base64-bytestring + , bcrypt + , blaze-builder + , blaze-html + , bytestring + , clay + , clientsession + , common + , config-manager + , containers + , cookie + , filepath + , http-conduit + , http-types + , jsaddle + , mime-mail + , monad-logger + , mtl + , parsec + , process + , random + , resourcet + , scotty + , sqlite-simple + , text + , time + , transformers + , unordered-containers + , uuid + , validation + , wai + , wai-extra + , wai-middleware-static + + other-modules: + Conf + Controller.Category + Controller.Helper + Controller.Income + Controller.Index + Controller.Payment + Controller.Statistics + Controller.User + Cookie + Design.Appearing + Design.Color + Design.Constants + Design.Errors + Design.Form + Design.Global + Design.Helper + Design.Loadable + Design.Media + Design.Modal + Design.Tooltip + Design.View.ConfirmDialog + Design.View.Header + Design.View.NotFound + Design.View.Pages + Design.View.Payment + Design.View.Payment.Form + Design.View.Payment.HeaderForm + Design.View.Payment.HeaderInfos + Design.View.SignIn + Design.View.Stat + Design.View.Table + Design.Views + Job.Daemon + Job.Frequency + Job.Kind + Job.Model + Job.MonthlyPayment + Job.WeeklyReport + LoginSession + Model.CreateCategory + Model.CreateIncome + Model.CreatePayment + Model.EditCategory + Model.EditIncome + Model.EditPayment + Model.HashedPassword + Model.IncomeResource + Model.Mail + Model.PaymentResource + Model.Query + Model.SignIn + Model.UUID + Payer + Persistence.Category + Persistence.Frequency + Persistence.Income + Persistence.Payment + Persistence.User + Persistence.Util + Resource + Secure + SendMail + Statistics + Util.Time + Validation.Category + Validation.Income + Validation.Payment + Validation.SignIn + View.Mail.WeeklyReport + View.Page diff --git a/src/server/Conf.hs b/server/src/Conf.hs index a05349d..ca19c8d 100644 --- a/src/server/Conf.hs +++ b/server/src/Conf.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} - module Conf ( get , Conf(..) ) where -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) + +import Common.Model (Currency (..)) data Conf = Conf - { hostname :: Text - , port :: Int + { hostname :: Text + , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text - , noReplyMail :: Text - , https :: Bool + , currency :: Currency + , noReplyMail :: Text + , https :: Bool + , devMode :: Bool } deriving Show get :: FilePath -> IO Conf @@ -28,10 +29,11 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf + Conf.lookup "https" conf <*> + Conf.lookup "devMode" conf ) case conf of Left msg -> error (T.unpack msg) - Right c -> return c + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..371ba78 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,88 @@ +module Controller.Category + ( listAll + , list + , create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) + +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Validation.Category as CategoryValidation + +listAll :: ActionM () +listAll = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json + ) + +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + usedCategories <- PaymentPersistence.usedCategories + count <- CategoryPersistence.count + return $ CategoryPage page categories usedCategories count + ) >>= json + ) + +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + CategoryPersistence.delete categoryId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted + ) diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs new file mode 100644 index 0000000..dc9cbc4 --- /dev/null +++ b/server/src/Controller/Helper.hs @@ -0,0 +1,16 @@ +module Controller.Helper + ( okOrBadRequest + ) where + +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do + S.status Status.badRequest400 + S.text (LT.fromStrict message) +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..96ccbbc --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,90 @@ +module Controller.Income + ( list + , create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (..)) +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty hiding (delete) + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..), + IncomeHeader (..), IncomeId, + IncomePage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure +import qualified Validation.Income as IncomeValidation + +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime + (liftIO . Query.run $ do + count <- IncomePersistence.count + + users <- UserPersistence.list + let userIds = _user_id <$> users + + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll + + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty + + incomes <- IncomePersistence.list page perPage + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json + ) + +create :: CreateIncomeForm -> ActionM () +create form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.createIncome form of + Success (CreateIncome amount date) -> do + Right <$> (IncomePersistence.create (_user_id user) date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditIncomeForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.editIncome form of + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: IncomeId -> ActionM () +delete incomeId = + Secure.loggedAction (\user -> do + _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId + status Status.ok200 + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..4f4ae77 --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,76 @@ +module Controller.Index + ( get + , signIn + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) +import qualified Network.HTTP.Types.Status as Status +import Prelude hiding (error, init) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import Common.Model (Init (..), SignInForm (..), + User (..)) +import qualified Common.Msg as Msg + +import Conf (Conf (..)) +import qualified LoginSession +import Model.Query (Query) +import qualified Model.Query as Query +import Model.SignIn (SignIn (..)) +import qualified Persistence.User as UserPersistence +import qualified Validation.SignIn as SignInValidation +import View.Page (page) + +get :: Conf -> ActionM () +get conf = do + init <- do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init + +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = + case SignInValidation.signIn form of + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init + + Nothing -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) + Nothing -> + return Nothing + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..d6aa34f --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,116 @@ +module Controller.Payment + ( list + , create + , edit + , delete + , searchCategory + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) +import qualified Model.Query as Query +import qualified Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure +import qualified Validation.Payment as PaymentValidation + +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search + + users <- UserPersistence.list + + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty + + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition + + header = PaymentHeader + { _paymentHeader_exceedingPayers = exceedingPayers + , _paymentHeader_repartition = searchRepartition + } + + return $ PaymentPage page frequency header payments count) >>= S.json + ) + +create :: CreatePaymentForm -> ActionM () +create form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.listAll + case PaymentValidation.createPayment cs form of + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditPaymentForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.listAll + case PaymentValidation.editPayment cs form of + Success (EditPayment paymentId name cost date category frequency) -> do + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_PaymentEdit + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +delete :: PaymentId -> ActionM () +delete paymentId = + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json + ) diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs new file mode 100644 index 0000000..500c93c --- /dev/null +++ b/server/src/Controller/Statistics.hs @@ -0,0 +1,21 @@ +module Controller.Statistics + ( paymentsAndIncomes + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Statistics + +paymentsAndIncomes :: ActionM () +paymentsAndIncomes = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + incomes <- liftIO $ Query.run IncomePersistence.listAll + S.json (Statistics.paymentsAndIncomes payments incomes) + ) diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs new file mode 100644 index 0000000..a7bb136 --- /dev/null +++ b/server/src/Controller/User.hs @@ -0,0 +1,17 @@ +module Controller.User + ( list + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ UserPersistence.list) >>= S.json + ) diff --git a/src/server/Cookie.hs b/server/src/Cookie.hs index 96d45da..f79a1fa 100644 --- a/src/server/Cookie.hs +++ b/server/src/Cookie.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Cookie ( makeSimpleCookie , setCookie @@ -9,25 +7,25 @@ module Cookie , deleteCookie ) where -import Control.Monad ( liftM ) +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 qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Data.Map as Map +import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as BSL -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Blaze.ByteString.Builder ( toLazyByteString ) +import Blaze.ByteString.Builder (toLazyByteString) -import Web.Scotty.Trans -import Web.Cookie +import Web.Cookie +import Web.Scotty.Trans makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie makeSimpleCookie conf name value = diff --git a/server/src/Design/Appearing.hs b/server/src/Design/Appearing.hs new file mode 100644 index 0000000..79b94b3 --- /dev/null +++ b/server/src/Design/Appearing.hs @@ -0,0 +1,25 @@ +module Design.Appearing + ( design + ) where + +import Clay + +design :: Css +design = do + + appearKeyframe + + ".g-Appearing" ? do + appearAnimation + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/src/server/Design/Color.hs b/server/src/Design/Color.hs index afc601f..e7f5aec 100644 --- a/src/server/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,12 +1,17 @@ module Design.Color where +import Clay import qualified Clay.Color as C +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 @@ -30,3 +35,6 @@ silver = C.rgb 200 200 200 dustyGray :: C.Color dustyGray = C.rgb 150 150 150 + +toString :: C.Color -> Text +toString = plain . unValue . value diff --git a/src/server/Design/Constants.hs b/server/src/Design/Constants.hs index 4e2b8cc..a3123d9 100644 --- a/src/server/Design/Constants.hs +++ b/server/src/Design/Constants.hs @@ -1,6 +1,6 @@ module Design.Constants where -import Clay +import Clay iconFontSize :: Size LengthUnit iconFontSize = px 32 diff --git a/src/server/Design/Errors.hs b/server/src/Design/Errors.hs index 57aaeee..9f435eb 100644 --- a/src/server/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Errors ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/src/server/Design/Form.hs b/server/src/Design/Form.hs index ebb8ac8..5713bfe 100644 --- a/src/server/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Form ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do @@ -16,24 +14,19 @@ 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) + marginBottom (em 2) paddingTop (px inputTop) marginTop (px (-10)) input ? do width (pct 100) position relative - zIndex inputZIndex backgroundColor transparent paddingBottom (px inputPaddingBottom) + paddingRight (px 14) -- Space for the delete icon borderStyle none borderBottom solid (px 1) Color.dustyGray marginBottom (px 5) @@ -43,22 +36,25 @@ design = do borderWidth (px 2) paddingBottom (px $ inputPaddingBottom - 1) - label ? do + ".label" ? do + zIndex (-1) + color Color.silver lineHeight (px inputHeight) position absolute top (px inputTop) left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) + transition "all" (sec 0.2) easeInOut (sec 0) button ? do position absolute right (px 0) top (px 27) - zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" + svg ? "path" ? + ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? + ("fill" -: Color.toString (Color.silver -. 25)) - (input # ".filled" |+ label) <> (input # focus |+ label) ? do + (input # ".filled" |+ ".label") <> (input # focus |+ ".label") ? do top (px 0) fontSize (pct 80) @@ -80,48 +76,23 @@ design = do borderColor transparent backgroundColor transparent - ".radioGroup" ? do - position relative - marginBottom (em 2) + ".selectInput" ? do - ".title" ? do + ".label" ? 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 + width (pct 100) 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) + option ? sym2 padding (px 5) (px 8) + focus & backgroundColor Color.wildSand + ".error" & do select ? borderColor Color.chestnutRose ".errorMessage" ? do diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs new file mode 100644 index 0000000..c67db7c --- /dev/null +++ b/server/src/Design/Global.hs @@ -0,0 +1,165 @@ +module Design.Global + ( globalDesign + ) where + +import Clay +import Clay.Color as C +import Data.Text.Lazy (Text) + +import qualified Design.Appearing as Appearing +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Errors as Errors +import qualified Design.Form as Form +import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable +import qualified Design.Media as Media +import qualified Design.Modal as Modal +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views + +globalDesign :: Text +globalDesign = renderWith compact [] global + +global :: Css +global = do + ".errors" ? Errors.design + Appearing.design + Modal.design + ".tooltip" ? Tooltip.design + Views.design + Form.design + Loadable.design + + spinKeyframes + appearKeyframe + + html ? do + height (pct 100) + + "g-Body--Modal" ? + overflowY hidden + + body ? do + position relative + minWidth (px 320) + height (pct 100) + fontFamily ["Cantarell"] [sansSerif] + Media.tablet $ do + fontSize (px 15) + button ? fontSize (px 15) + input ? fontSize (px 15) + Media.mobile $ do + fontSize (px 14) + button ? fontSize (px 14) + input ? fontSize (px 14) + + ".app" ? do + appearAnimation + display flex + height (pct 100) + flexDirection column + + -- "main" ? + -- appearAnimation + + ".pageSpinner" ? do + display flex + alignItems center + justifyContent center + flexGrow 1 + + ".spinner" ? do + display flex + alignItems center + justifyContent center + width (pct 100) + height (pct 100) + paddingBottom (pct 10) + + before & do + display block + content (stringContent "") + width (px 50) + height (px 50) + border solid (px 3) (C.setA 0.3 Color.chestnutRose) + sym borderRadius (pct 50) + borderTopColor Color.chestnutRose + spinKeyframes + spinAnimation + + a ? cursor pointer + + input ? fontSize inherit + + h1 ? do + color Color.chestnutRose + lineHeight (em 1.3) + + Media.desktop $ fontSize (px 24) + Media.tablet $ fontSize (px 22) + Media.mobile $ fontSize (px 20) + + ul ? do + "margin-top" -: "1vh" + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li <? do + "margin-bottom" -: "2vh" + before & do + content (stringContent "• ") + color Color.chestnutRose + "margin-right" -: "0.3vw" + ul <? do + "margin-left" -: "3vh" + "margin-top" -: "2vh" + + ".dialog" ? ".content" ? button ? do + ".confirm" & Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + svg ? height (pct 100) + + button ? do + position relative + + ".content" ? do + display flex + + svg # ".loader" ? do + display none + position absolute + + ".waiting" & do + ".content" ? do + opacity 0 + svg # ".loader" ? do + display block + spinAnimation + + select ? cursor pointer + +spinAnimation :: Css +spinAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeInOut + animationIterationCount infinite + +spinKeyframes :: Css +spinKeyframes = keyframes + "rotate" + [ (100, "transform" -: "rotate(360deg)") + ] + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/src/server/Design/Helper.hs b/server/src/Design/Helper.hs index 869616d..e586d56 100644 --- a/src/server/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,22 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Helper ( clearFix , button - , input - , iconButton , centeredWithMargin , verticalCentering ) where -import Prelude hiding (span) - -import Clay hiding (button, input) +import Prelude hiding (span) -import Data.Monoid ((<>)) +import Clay hiding (button) -import Design.Constants -import Design.Color as Color +import Design.Constants clearFix :: Css clearFix = @@ -27,6 +20,9 @@ clearFix = button :: Color -> Color -> Size a -> (Color -> Color) -> Css button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center backgroundColor backgroundCol padding (px 0) (px 10) (px 0) (px 10) color textCol @@ -39,28 +35,6 @@ button backgroundCol textCol h focusOp = do 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) diff --git a/server/src/Design/Loadable.hs b/server/src/Design/Loadable.hs new file mode 100644 index 0000000..6b13f2d --- /dev/null +++ b/server/src/Design/Loadable.hs @@ -0,0 +1,29 @@ +module Design.Loadable + ( design + ) where + +import Clay + +design :: Css +design = do + ".g-Loadable" ? do + position relative + width (pct 100) + height (pct 100) + + ".g-Loadable__Spinner" ? do + position absolute + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + display none + + ".g-Loadable__Spinner--Loading" ? do + display block + + ".g-Loadable__Content" ? + transition "opacity" (sec 0.4) ease (sec 0) + + ".g-Loadable__Content--Loading" ? + opacity 0.5 diff --git a/src/server/Design/Media.hs b/server/src/Design/Media.hs index 77220ee..19a3b8c 100644 --- a/src/server/Design/Media.hs +++ b/server/src/Design/Media.hs @@ -6,10 +6,10 @@ module Design.Media , desktop ) where -import Clay hiding (query) +import Clay hiding (query) import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media +import qualified Clay.Media as Media +import Clay.Stylesheet (Feature) mobile :: Css -> Css mobile = query [Media.maxWidth mobileTabletLimit] diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs new file mode 100644 index 0000000..1195e10 --- /dev/null +++ b/server/src/Design/Modal.hs @@ -0,0 +1,69 @@ +module Design.Modal + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.View.Payment.Form as Form + +design :: Css +design = do + + appearKeyframe + + ".g-Modal" ? do + display none + appearAnimation + transition "all" (sec 0.2) ease (sec 0) + opacity 0 + + ".g-Modal--Show" & do + display block + opacity 1 + + ".g-Modal--Hiding" & do + display block + + ".g-Modal__Curtain" ? do + position fixed + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + backgroundColor (rgba 0 0 0 0.6) + zIndex 1 + + ".g-Modal__Content" ? do + minWidth (px 300) + position fixed + top (pct 25) + left (pct 50) + "transform" -: "translate(-50%, -25%)" + zIndex 1 + backgroundColor white + sym borderRadius (px 5) + boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) + + ".form" ? Form.design + + ".paymentModal" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentModal" <> ".deleteIncomeModal" ? do + h1 ? marginBottom (em 1.5) + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.15) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/src/server/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 1da8764..eef804e 100644 --- a/src/server/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Tooltip ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/View/ConfirmDialog.hs b/server/src/Design/View/ConfirmDialog.hs new file mode 100644 index 0000000..410d4d8 --- /dev/null +++ b/server/src/Design/View/ConfirmDialog.hs @@ -0,0 +1,36 @@ +module Design.View.ConfirmDialog + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".confirm" ? do + ".confirmHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".confirmContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/src/server/Design/Header.hs b/server/src/Design/View/Header.hs index 8feac64..609d8fc 100644 --- a/src/server/Design/Header.hs +++ b/server/src/Design/View/Header.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Header +module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Media as Media design :: Css @@ -27,7 +25,6 @@ design = do ".title" <> ".item" ? headerPadding ".title" ? do - height (pct 100) textAlign (alignSide sideLeft) Media.mobile $ fontSize (px 22) @@ -42,8 +39,11 @@ design = do ".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) + (".item" # hover) <> (".item" # focus) ? + backgroundColor (Color.chestnutRose +. 10) + + (".item.current" # hover) <> (".item.current" # focus) ? + backgroundColor (Color.chestnutRose -. 10) ".nameSignOut" ? do display flex @@ -57,9 +57,13 @@ design = do Media.tabletDesktop $ headerPadding ".signOut" ? do - heightMedia + display flex + justifyContent center + alignItems center svg ? do + Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") lineHeightMedia :: Css lineHeightMedia = do diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs new file mode 100644 index 0000000..150c6fc --- /dev/null +++ b/server/src/Design/View/NotFound.hs @@ -0,0 +1,21 @@ +module Design.View.NotFound + ( design + ) where + +import Clay +import Prelude hiding (rem) + +import qualified Design.Color as Color + +design :: Css +design = do + + marginLeft (rem 3) + + ".link" ? do + display block + marginTop (rem 1) + color Color.chestnutRose + textDecoration underline + hover & + color (Color.chestnutRose +. 15) diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs new file mode 100644 index 0000000..1482ef4 --- /dev/null +++ b/server/src/Design/View/Pages.hs @@ -0,0 +1,55 @@ +module Design.View.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = + ".pages" ? do + display flex + justifyContent center + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs new file mode 100644 index 0000000..d563f5d --- /dev/null +++ b/server/src/Design/View/Payment.hs @@ -0,0 +1,13 @@ +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.HeaderForm as HeaderForm +import qualified Design.View.Payment.HeaderInfos as HeaderInfos + +design :: Css +design = do + HeaderForm.design + HeaderInfos.design diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs new file mode 100644 index 0000000..5ecae7a --- /dev/null +++ b/server/src/Design/View/Payment/Add.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Add + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".addHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".addContent" ? do + sym2 padding (px 20) (px 30) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/Form.hs b/server/src/Design/View/Payment/Form.hs new file mode 100644 index 0000000..aada12b --- /dev/null +++ b/server/src/Design/View/Payment/Form.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Form + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".formHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".formContent" ? do + sym2 padding (px 20) (px 30) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..6081443 --- /dev/null +++ b/server/src/Design/View/Payment/HeaderForm.hs @@ -0,0 +1,40 @@ +module Design.View.Payment.HeaderForm + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderForm" ? do + marginBottom (em 2) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + display flex + justifyContent spaceBetween + alignItems center + Media.mobile $ flexDirection column + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock + Media.mobile $ marginBottom (em 2) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + flexShrink 0 diff --git a/server/src/Design/View/Payment/HeaderInfos.hs b/server/src/Design/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..acb393b --- /dev/null +++ b/server/src/Design/View/Payment/HeaderInfos.hs @@ -0,0 +1,50 @@ +module Design.View.Payment.HeaderInfos + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderInfos" ? do + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + + ".g-PaymentHeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + marginBottom (em 1) + + Media.mobile $ do + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".g-PaymentHeaderInfos__Repartition" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs new file mode 100644 index 0000000..42c9621 --- /dev/null +++ b/server/src/Design/View/SignIn.hs @@ -0,0 +1,36 @@ +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) +import Prelude hiding (rem) + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + let inputHeight = 50 + width (px 350) + sym2 padding (rem 0) (rem 2) + marginTop (px 100) + marginLeft auto + marginRight auto + + button # ".validate" ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/src/server/Design/LoggedIn/Stat.hs b/server/src/Design/View/Stat.hs index 62028cb..2e4ecad 100644 --- a/src/server/Design/LoggedIn/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Stat +module Design.View.Stat ( design ) where -import Clay +import Clay design :: Css design = do @@ -13,3 +11,7 @@ design = do ".exceedingPayers" ? ".userName" ? marginRight (px 5) ".mean" ? marginBottom (em 1.5) + + ".g-Chart" ? do + width (pct 75) + sym2 margin (px 0) auto diff --git a/src/server/Design/LoggedIn/Table.hs b/server/src/Design/View/Table.hs index 44b001a..56bd389 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/server/src/Design/View/Table.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Table +module Design.View.Table ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Media as Media design :: Css @@ -17,6 +15,9 @@ design = do margin (em 2) (em 2) (em 2) (em 2) textAlign (alignSide sideCenter) + ".table" ? do + minHeight (px 540) + ".lines" ? do Media.tabletDesktop $ display displayTable width (pct 100) @@ -69,11 +70,25 @@ design = do ".refund" & color Color.mossGreen + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + ".cell.button" & do position relative textAlign (alignSide sideCenter) button ? do padding (px 10) (px 10) (px 10) (px 10) + svg ? do + "path" ? ("fill" -: Color.toString Color.chestnutRose) + width (px 18) hover & "svg path" ? do "fill" -: "rgb(237, 122, 116)" diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs new file mode 100644 index 0000000..4552796 --- /dev/null +++ b/server/src/Design/Views.hs @@ -0,0 +1,56 @@ +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.ConfirmDialog as ConfirmDialog +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +design :: Css +design = do + header ? Header.design + Payment.design + ".signIn" ? SignIn.design + Stat.design + ".notfound" ? NotFound.design + Table.design + Pages.design + ConfirmDialog.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + display flex + marginBottom (em 1) + + Media.tabletDesktop $ do + justifyContent spaceBetween + alignItems center + + Media.mobile $ do + flexDirection column + "h1" ? marginBottom (em 0.5) + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow . pure . bsColor (rgba 0 0 0 0.3) $ shadowWithBlur (px 2) (px 2) (px 5) + color Color.white diff --git a/src/server/Job/Daemon.hs b/server/src/Job/Daemon.hs index 0bc6f6e..d8cd522 100644 --- a/src/server/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -2,18 +2,19 @@ module Job.Daemon ( runDaemons ) where -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Conf (Conf) +import Job.Frequency (Frequency (..), microSeconds) +import Job.Kind (Kind (..)) +import Job.Model (actualizeLastCheck, actualizeLastExecution, + getLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do @@ -29,7 +30,7 @@ runDaemon kind frequency isLastExecutionTooOld runJob = getLastExecution kind hasToRun <- case mbLastExecution of Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True + Nothing -> return True if hasToRun then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () diff --git a/src/server/Job/Frequency.hs b/server/src/Job/Frequency.hs index 263f6e6..c5bef42 100644 --- a/src/server/Job/Frequency.hs +++ b/server/src/Job/Frequency.hs @@ -10,4 +10,4 @@ data Frequency = microSeconds :: Frequency -> Int microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..17997f7 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,23 @@ +module Job.Kind + ( Kind(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/src/server/Job/Model.hs b/server/src/Job/Model.hs index e1a3c77..1dd6c63 100644 --- a/src/server/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Job.Model ( Job(..) , getLastExecution @@ -7,34 +5,38 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Job.Kind -import Model.Query (Query(Query)) +import Job.Kind +import Model.Query (Query (Query)) data Job = Job - { id :: String - , kind :: Kind + { id :: String + , kind :: Kind , lastExecution :: Maybe UTCTime - , lastCheck :: 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 + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing ) actualizeLastExecution :: Kind -> UTCTime -> Query () actualizeLastExecution jobKind time = Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..dfbe8b4 --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Util.Time as Time + +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName + now <- getCurrentTime + actualDay <- Time.timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (PaymentPersistence.createMany punctualPayments) + return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..ff80ddf --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,51 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +import qualified Data.Map as M +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (User (..)) + +import Conf (Conf) +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + + case mbLastExecution of + Nothing -> + return () + + Just lastExecution -> do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty + weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) + + return () + + return now diff --git a/src/server/LoginSession.hs b/server/src/LoginSession.hs index 6f6d620..86f1329 100644 --- a/src/server/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} - module LoginSession ( put , get , delete ) where -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS +import Cookie (deleteCookie, getCookie, + setSimpleCookie) +import qualified Web.ClientSession as CS +import Web.Scotty (ActionM) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import qualified Data.Text.Encoding as TE +import Data.Text (Text) +import qualified Data.Text.Encoding as TE -import Conf (Conf) +import Conf (Conf) sessionName :: Text sessionName = "SESSION" diff --git a/server/src/Main.hs b/server/src/Main.hs new file mode 100644 index 0000000..659a0fa --- /dev/null +++ b/server/src/Main.hs @@ -0,0 +1,106 @@ +module Main + ( main + ) where + +import qualified Network.HTTP.Types.Status as Status +import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) +import qualified Network.Wai.Middleware.Gzip as W +import Network.Wai.Middleware.Static +import qualified Web.Scotty as S + +import qualified Conf +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.Statistics as Statistics +import qualified Controller.User as User +import qualified Design.Global as Design +import Job.Daemon (runDaemons) + +main :: IO () +main = do + conf <- Conf.get "application.conf" + putStrLn . show $ conf + _ <- runDaemons conf + S.scotty (Conf.port conf) $ do + + S.middleware $ + W.gzip $ W.def { W.gzipFiles = GzipCompress } + + S.middleware . staticPolicy $ + noDots >-> addBase "public" + + S.get "/css/main.css" $ do + S.setHeader "Content-Type" "text/css" + S.text Design.globalDesign + + S.post "/api/signIn" $ + S.jsonData >>= Index.signIn conf + + S.post "/api/signOut" $ + Index.signOut conf + + S.get "/api/users"$ + User.list + + S.get "/api/payments" $ do + frequency <- S.param "frequency" + page <- S.param "page" + perPage <- S.param "perPage" + search <- S.param "search" + Payment.list (read frequency) page perPage search + + S.get "/api/payment/category" $ do + name <- S.param "name" + Payment.searchCategory name + + S.post "/api/payment" $ + S.jsonData >>= Payment.create + + S.put "/api/payment" $ + S.jsonData >>= Payment.edit + + S.delete "/api/payment/:id" $ do + paymentId <- S.param "id" + Payment.delete paymentId + + S.get "/api/incomes" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Income.list page perPage + + S.post "/api/income" $ + S.jsonData >>= Income.create + + S.put "/api/income" $ + S.jsonData >>= Income.edit + + S.delete "/api/income/:id" $ do + incomeId <- S.param "id" + Income.delete incomeId + + S.get "/api/allCategories" $ do + Category.listAll + + S.get "/api/categories" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Category.list page perPage + + S.post "/api/category" $ + S.jsonData >>= Category.create + + S.put "/api/category" $ + S.jsonData >>= Category.edit + + S.delete "/api/category/:id" $ do + categoryId <- S.param "id" + Category.delete categoryId + + S.get "/api/statistics" $ do + Statistics.paymentsAndIncomes + + S.notFound $ do + S.status Status.ok200 + Index.get conf diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs new file mode 100644 index 0000000..dae061b --- /dev/null +++ b/server/src/Model/CreateCategory.hs @@ -0,0 +1,10 @@ +module Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Text (Text) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/CreateIncome.hs b/server/src/Model/CreateIncome.hs new file mode 100644 index 0000000..82451d2 --- /dev/null +++ b/server/src/Model/CreateIncome.hs @@ -0,0 +1,10 @@ +module Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Time.Calendar (Day) + +data CreateIncome = CreateIncome + { _createIncome_amount :: Int + , _createIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs new file mode 100644 index 0000000..b25d2a4 --- /dev/null +++ b/server/src/Model/CreatePayment.hs @@ -0,0 +1,16 @@ +module Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs new file mode 100644 index 0000000..8ee26ac --- /dev/null +++ b/server/src/Model/EditCategory.hs @@ -0,0 +1,13 @@ +module Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Text (Text) + +import Common.Model (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/EditIncome.hs b/server/src/Model/EditIncome.hs new file mode 100644 index 0000000..ac3d311 --- /dev/null +++ b/server/src/Model/EditIncome.hs @@ -0,0 +1,13 @@ +module Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Time.Calendar (Day) + +import Common.Model (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_amount :: Int + , _editIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs new file mode 100644 index 0000000..ac4c906 --- /dev/null +++ b/server/src/Model/EditPayment.hs @@ -0,0 +1,17 @@ +module Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency, PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs new file mode 100644 index 0000000..c71e372 --- /dev/null +++ b/server/src/Model/HashedPassword.hs @@ -0,0 +1,27 @@ +module Model.HashedPassword + ( hash + , check + , HashedPassword(..) + ) where + +import qualified Crypto.BCrypt as BCrypt +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Common.Model.Password (Password (..)) + +newtype HashedPassword = HashedPassword Text deriving (Show) + +hash :: Password -> IO (Maybe HashedPassword) +hash (Password p) = do + hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p) + case hashed of + Nothing -> + return Nothing + + Just h -> + return . Just . HashedPassword . TE.decodeUtf8 $ h + +check :: Password -> HashedPassword -> Bool +check (Password p) (HashedPassword h) = + BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p) diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs new file mode 100644 index 0000000..6ab5f18 --- /dev/null +++ b/server/src/Model/IncomeResource.hs @@ -0,0 +1,15 @@ +module Model.IncomeResource + ( IncomeResource(..) + ) where + +import Common.Model (Income (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype IncomeResource = IncomeResource Income + +instance Resource IncomeResource where + resourceCreatedAt (IncomeResource i) = _income_createdAt i + resourceEditedAt (IncomeResource i) = _income_editedAt i + resourceDeletedAt (IncomeResource i) = _income_deletedAt i diff --git a/src/server/Model/Mail.hs b/server/src/Model/Mail.hs index 9a4db73..780efcc 100644 --- a/src/server/Model/Mail.hs +++ b/server/src/Model/Mail.hs @@ -2,11 +2,11 @@ module Model.Mail ( Mail(..) ) where -import Data.Text (Text) +import Data.Text (Text) data Mail = Mail - { from :: Text - , to :: [Text] + { from :: Text + , to :: [Text] , subject :: Text - , plainBody :: Text + , body :: Text } deriving (Eq, Show) diff --git a/server/src/Model/PaymentResource.hs b/server/src/Model/PaymentResource.hs new file mode 100644 index 0000000..1ea978c --- /dev/null +++ b/server/src/Model/PaymentResource.hs @@ -0,0 +1,15 @@ +module Model.PaymentResource + ( PaymentResource(..) + ) where + +import Common.Model (Payment (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype PaymentResource = PaymentResource Payment + +instance Resource PaymentResource where + resourceCreatedAt (PaymentResource p) = _payment_createdAt p + resourceEditedAt (PaymentResource p) = _payment_editedAt p + resourceDeletedAt (PaymentResource p) = _payment_deletedAt p diff --git a/src/server/Model/Query.hs b/server/src/Model/Query.hs index d15fb5f..22ae95b 100644 --- a/src/server/Model/Query.hs +++ b/server/src/Model/Query.hs @@ -3,8 +3,8 @@ module Model.Query , run ) where -import Data.Functor (Functor) -import Database.SQLite.Simple (Connection) +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) import qualified Database.SQLite.Simple as SQLite data Query a = Query (Connection -> IO a) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs new file mode 100644 index 0000000..a217bae --- /dev/null +++ b/server/src/Model/SignIn.hs @@ -0,0 +1,10 @@ +module Model.SignIn + ( SignIn(..) + ) where + +import Common.Model (Email, Password) + +data SignIn = SignIn + { _signIn_email :: Email + , _signIn_password :: Password + } deriving Show diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs new file mode 100644 index 0000000..0959a8e --- /dev/null +++ b/server/src/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.Text (Text, pack) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Payer.hs b/server/src/Payer.hs new file mode 100644 index 0000000..ab8312e --- /dev/null +++ b/server/src/Payer.hs @@ -0,0 +1,87 @@ +module Payer + ( getExceedingPayers + ) where + +import Data.Map (Map) +import qualified Data.Map as M + +import Common.Model (ExceedingPayer (..), User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_income :: Int + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = + let userIds = map _user_id users + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition = + flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition + , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition + , _payer_income = M.findWithDefault 0 userId cumulativeIncome + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) + } + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs new file mode 100644 index 0000000..b0a6fca --- /dev/null +++ b/server/src/Persistence/Category.hs @@ -0,0 +1,123 @@ +module Persistence.Category + ( count + , list + , listAll + , create + , edit + , delete + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category (..), CategoryId) + +import Model.Query (Query (Query)) + +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL" + ) + + +list :: Int -> Int -> Query [Category] +list page perPage = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.queryNamed + conn + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listAll :: Query [Category] +listAll = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query () +create name color = + Query (\conn -> do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)" + [ ":name" := name + , ":color" := color + , ":created_at" := currentTime + ] + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit id name color = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> + (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ]) + if Maybe.isJust mbCategory + then do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id" + [ ":editedAt" := currentTime + , ":name" := name + , ":color" := color + , ":id" := id + ] + return True + else + return False + ) + +data BoolRow = BoolRow Int + +instance FromRow BoolRow where + fromRow = BoolRow <$> SQLite.field + +delete :: CategoryId -> Query Bool +delete id = + Query (\conn -> do + mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$> + (SQLite.queryNamed + conn + "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL" + [ ":id" := id ]) + if Maybe.isNothing mbPayment + then do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL" + [ ":deletedAt" := currentTime + , ":id" := id + ] + return True + else + return False + ) diff --git a/server/src/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs new file mode 100644 index 0000000..edaa844 --- /dev/null +++ b/server/src/Persistence/Frequency.hs @@ -0,0 +1,23 @@ +module Persistence.Frequency + ( FrequencyField(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +import Common.Model (Frequency) + +newtype FrequencyField = FrequencyField Frequency + +instance FromField FrequencyField where + fromField field = + case fieldData field of + SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency)) + _ -> Errors [error "SQLText field required for frequency"] + +instance ToField FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs new file mode 100644 index 0000000..1b5364c --- /dev/null +++ b/server/src/Persistence/Income.hs @@ -0,0 +1,201 @@ +module Persistence.Income + ( listAll + , count + , list + , listModifiedSince + , create + , edit + , delete + , definedForAll + , getCumulativeIncome + ) where + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id, until) + +import Common.Model (Income (..), IncomeId, PaymentId, + UserId) + +import Model.Query (Query (Query)) + +newtype Row = Row Income + +instance FromRow Row where + fromRow = Row <$> (Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC" + ) + + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" + ) + +list :: Int -> Int -> Query [Income] +list page perPage = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listModifiedSince :: UTCTime -> Query [Income] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM income" + , "WHERE" + , "created_at >= :since" + , "OR edited_at >= :since" + , "OR deleted_at >= :since" + ]) + [ ":since" := since ] + ) + +create :: UserId -> Day -> Int -> Query () +create userId date amount = + Query (\conn -> do + createdAt <- getCurrentTime + SQLite.executeNamed + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (:userId, :date, :amount, :createdAt)" + [ ":userId" := userId + , ":date" := date + , ":amount" := amount + , ":createdAt" := createdAt + ] + ) + +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool +edit userId id date amount = + Query (\conn -> do + income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> + SQLite.queryNamed conn "SELECT * FROM income WHERE id = :id" [ ":id" := id ] + if Maybe.isJust income then + do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + "UPDATE income SET edited_at = :editedAt, date = :date, amount = :amount WHERE id = :id AND user_id = :userId" + [ ":editedAt" := currentTime + , ":date" := date + , ":amount" := amount + , ":id" := id + , ":userId" := userId + ] + return True + else + return False + ) + +delete :: UserId -> PaymentId -> Query () +delete userId id = + Query (\conn -> + SQLite.executeNamed + conn + "UPDATE income SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := id + , ":userId" := userId + ] + ) + +data UserDayRow = UserDayRow (UserId, Day) + +instance FromRow UserDayRow where + fromRow = do + user <- SQLite.field + day <- SQLite.field + return $ UserDayRow (user, day) + +definedForAll :: [UserId] -> Query (Maybe Day) +definedForAll users = + Query (\conn -> + (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$> + SQLite.query_ + conn + "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;" + ) + where + fromRows rows = + if L.sort users == L.sort (map fst rows) then + Maybe.listToMaybe . reverse . L.sort . map snd $ rows + else + Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs new file mode 100644 index 0000000..573d57f --- /dev/null +++ b/server/src/Persistence/Payment.hs @@ -0,0 +1,389 @@ +module Persistence.Payment + ( count + , find + , getRange + , listAllPunctual + , listActivePage + , listModifiedPunctualSince + , listActiveMonthlyOrderedByName + , create + , createMany + , edit + , delete + , searchCategory + , repartition + , getPreAndPostPaymentRepartition + , usedCategories + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), + NamedParam ((:=)), ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id, until) + +import Common.Model (CategoryId, Frequency (..), + Payment (..), PaymentId, + User (..), UserId) +import qualified Common.Util.Text as TextUtil + +import Model.Query (Query (Query)) +import Persistence.Frequency (FrequencyField (..)) +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Util as PersistenceUtil + + +fields :: Text +fields = T.intercalate "," $ + [ "id" + , "user_id" + , "name" + , "cost" + , "date" + , "category" + , "frequency" + , "created_at" + , "edited_at" + , "deleted_at" + ] + +newtype Row = Row Payment + +instance FromRow Row where + fromRow = Row <$> (Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +newtype InsertRow = InsertRow Payment + +instance ToRow InsertRow where + toRow (InsertRow p) = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_category p) + , toField (FrequencyField (_payment_frequency p)) + , toField (_payment_createdAt p) + ] + +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Frequency -> Text -> Query Int +count frequency search = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT COUNT(*)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + ]) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + ] + ) + +find :: PaymentId -> Query (Maybe Payment) +find paymentId = + Query (\conn -> do + fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = :id") + [ "id" := paymentId + ] + ) + +data RangeRow = RangeRow (Day, Day) + +instance FromRow RangeRow where + fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field + +getRange :: Query (Maybe (Day, Day)) +getRange = + Query (\conn -> do + fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT MIN(date), MAX(date)" + , "FROM payment" + , "WHERE" + , "frequency = :frequency" + , "AND deleted_at IS NULL" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + +listAllPunctual :: Query [Payment] +listAllPunctual = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY date" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + + +listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] +listActivePage frequency page perPage search = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "ORDER BY date DESC" + , "LIMIT :limit" + , "OFFSET :offset" + ] + ) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] + ) + +listModifiedPunctualSince :: UTCTime -> Query [Payment] +listModifiedPunctualSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT " <> fields + , "FROM payment" + , "WHERE" + , "frequency = :frequency" + , "AND (created_at >= :since OR edited_at >= :since OR deleted_at >= :since)" + ]) + [ ":frequency" := FrequencyField Punctual + , ":since" := since + ] + ) + + +listActiveMonthlyOrderedByName :: Query [Payment] +listActiveMonthlyOrderedByName = + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY name DESC" + ]) + [ ":frequency" := FrequencyField Monthly + ] + ) + +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () +create userId name cost date category frequency = + Query (\conn -> do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (:userId, :name, :cost, :date, :category, :frequency, :currentTime)" + ]) + [ ":userId" := userId + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":currentTime" := currentTime + ] + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" + ]) + (map InsertRow payments) + ) + +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool +edit userId paymentId name cost date category frequency = + Query (\conn -> do + payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query $ + "SELECT " <> fields <> " FROM payment WHERE id = :paymentId and user_id = :userId") + [ ":paymentId" := paymentId + , ":userId" := userId + ] + if Maybe.isJust payment then + do + currentTime <- getCurrentTime + SQLite.executeNamed + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE" + , " payment" + , "SET" + , " edited_at = :editedAt," + , " name = :name," + , " cost = :cost," + , " date = :date," + , " category = :category," + , " frequency = :frequency" + , "WHERE" + , " id = :id" + , " AND user_id = :userId" + ]) + [ ":editedAt" := currentTime + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":id" := paymentId + , ":userId" := userId + ] + return True + else + return False + ) + +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.executeNamed + conn + "UPDATE payment SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := paymentId + , ":userId" := userId + ] + ) + +data CategoryIdRow = CategoryIdRow CategoryId + +instance FromRow CategoryIdRow where + fromRow = CategoryIdRow <$> SQLite.field + +searchCategory :: Text -> Query (Maybe CategoryId) +searchCategory paymentName = + Query (\conn -> + fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE :name" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) + [ ":name" := "%" <> paymentName <> "%" + ] + ) + +usedCategories :: Query [CategoryId] +usedCategories = + Query (\conn -> do + map (\(CategoryIdRow p) -> p) <$> + SQLite.query_ + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT DISTINCT category" + , "FROM payment" + , "WHERE deleted_at IS NULL" + ]) + ) + +data UserCostRow = UserCostRow (UserId, Int) + +instance FromRow UserCostRow where + fromRow = do + user <- SQLite.field + cost <- SQLite.field + return $ UserCostRow (user, cost) + +repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) +repartition frequency search from to = + Query (\conn -> + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.queryNamed + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT user_id, SUM(cost)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "AND date >= :from" + , "AND date < :to" + , "GROUP BY user_id" + ]) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":from" := from + , ":to" := to + ] + ) + +getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) +getPreAndPostPaymentRepartition paymentRange users = do + case paymentRange of + Just (from, to) -> do + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + (,) + <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll)) + <*> (case incomeDefinedForAll of + Just d -> repartition Punctual "" d (Calendar.addDays 1 to) + Nothing -> return M.empty) + + Nothing -> + return (M.empty, M.empty) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs new file mode 100644 index 0000000..12145ac --- /dev/null +++ b/server/src/Persistence/User.hs @@ -0,0 +1,78 @@ +module Persistence.User + ( list + , get + , checkPassword + , createSignInToken + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Email (..), Password (..), User (..)) + +import Model.HashedPassword (HashedPassword (..)) +import qualified Model.HashedPassword as HashedPassword +import Model.Query (Query (Query)) +import qualified Model.UUID as UUID + +newtype Row = Row User + +instance FromRow Row where + fromRow = Row <$> (User <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [User] +list = + Query (\conn -> do + map (\(Row u) -> u) <$> + SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC" + ) + +get :: Text -> Query (Maybe User) +get token = + Query (\conn -> do + fmap (\(Row u) -> u) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1" + [ ":sign_in_token" := token ] + ) + +data HashedPasswordRow = HashedPasswordRow HashedPassword + +instance FromRow HashedPasswordRow where + fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field) + +checkPassword :: Email -> Password -> Query Bool +checkPassword (Email email) password = + Query (\conn -> do + hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT password FROM user WHERE email = :email LIMIT 1" + [ ":email" := email ] + case hashedPassword of + Just h -> + return (HashedPassword.check password h) + + Nothing -> + return False + ) + +createSignInToken :: Email -> Query Text +createSignInToken (Email email) = + Query (\conn -> do + token <- UUID.generateUUID + SQLite.executeNamed + conn + "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email" + [ ":sign_in_token" := token + , ":email" := email + ] + return token + ) diff --git a/server/src/Persistence/Util.hs b/server/src/Persistence/Util.hs new file mode 100644 index 0000000..b7496c6 --- /dev/null +++ b/server/src/Persistence/Util.hs @@ -0,0 +1,11 @@ +module Persistence.Util + ( formatKeyForSearch + ) where + +import Data.Text (Text) + +formatKeyForSearch :: Text -> Text +formatKeyForSearch key = + "replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(" + <> key + <> "), 'à', 'a'), 'â', 'a'), 'ç', 'c'), 'è', 'e'), 'é', 'e'), 'ê', 'e'), 'ë', 'e'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ù', 'u'), 'û', 'u'), 'ü', 'u')" diff --git a/src/server/Resource.hs b/server/src/Resource.hs index f52bbfa..a12a0f2 100644 --- a/src/server/Resource.hs +++ b/server/src/Resource.hs @@ -9,10 +9,10 @@ module Resource , statusDuring ) where -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) class Resource a where resourceCreatedAt :: a -> UTCTime @@ -34,7 +34,7 @@ groupByStatus start end resources = (\m resource -> case statusDuring start end resource of Just status -> M.insertWith (++) status [resource] m - Nothing -> m + Nothing -> m ) M.empty resources diff --git a/server/src/Secure.hs b/server/src/Secure.hs new file mode 100644 index 0000000..a30941f --- /dev/null +++ b/server/src/Secure.hs @@ -0,0 +1,31 @@ +module Secure + ( loggedAction + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import qualified Network.HTTP.Types.Status as HTTP +import Web.Scotty + +import Common.Model (User) +import qualified Common.Msg as Msg + +import qualified LoginSession +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence + +loggedAction :: (User -> ActionM ()) -> ActionM () +loggedAction action = do + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . Query.run . UserPersistence.get $ token + case maybeUser of + Just user -> + action user + Nothing -> do + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized + Nothing -> do + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs new file mode 100644 index 0000000..13d4072 --- /dev/null +++ b/server/src/SendMail.hs @@ -0,0 +1,66 @@ +module SendMail + ( sendMail + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) +import qualified Network.Mail.Mime as M + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) + +import Conf (Conf) +import qualified Conf +import Model.Mail (Mail (..)) + +sendMail :: Conf -> Mail -> IO (Either Text ()) +sendMail conf mail = + if Conf.devMode conf + then + do + T.putStrLn . mockMailMessage $ mail + return (Right ()) + else + do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else return () + return result + +mockMailMessage :: Mail -> Text +mockMailMessage mail = T.concat $ + [ "[MOCK MAIL] " + , subject mail + , " (from: " + , from mail + , ") (to: " + , T.intercalate ", " $ to mail + , ")" + , "\n" + , body mail + , "\n" + ] + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = + let fromMail = M.emptyMail (address mailFrom) + in fromMail + { M.mailTo = map address mailTo + , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] + , M.mailHeaders = [("Subject", mailSubject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs new file mode 100644 index 0000000..e463aac --- /dev/null +++ b/server/src/Statistics.hs @@ -0,0 +1,59 @@ +module Statistics + ( paymentsAndIncomes + ) where + +import Control.Arrow ((&&&)) +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Time.Calendar as Calendar + +import Common.Model (Income (..), MonthStats (..), Payment (..), + Stats) + +paymentsAndIncomes :: [Payment] -> [Income] -> Stats +paymentsAndIncomes payments incomes = + + map toMonthStat . M.toList $ foldl + (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) + M.empty + payments + + where + + toMonthStat (start, paymentsByCategory) = + MonthStats start paymentsByCategory (incomesAt start) + + incomesAt day = + M.map (incomeAt day) lastToFirstIncomesByUser + + incomeAt day lastToFirstIncome = + Maybe.maybe 0 _income_amount + . Maybe.listToMaybe + . dropWhile (\i -> _income_date i > day) + $ lastToFirstIncome + + lastToFirstIncomesByUser = + M.map (reverse . L.sortOn _income_date) + . groupBy _income_userId + $ incomes + + initMonthStats = + M.fromList + . map (\category -> (category, 0)) + . L.nub + $ map _payment_category payments + + alter p Nothing = Just (addPayment p initMonthStats) + alter p (Just monthStats) = Just (addPayment p monthStats) + + addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats + + startOfMonth day = + let (y, m, _) = Calendar.toGregorian day + in Calendar.fromGregorian y m 1 + +groupBy :: Ord k => (a -> k) -> [a] -> Map k [a] +groupBy key = + M.fromListWith (++) . map (key &&& pure) diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs new file mode 100644 index 0000000..4a29fcc --- /dev/null +++ b/server/src/Util/Time.hs @@ -0,0 +1,22 @@ +module Util.Time + ( belongToCurrentMonth + , belongToCurrentWeek + ) where + +import Data.Time.Calendar (toGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) + +import qualified Common.Util.Time as Time + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs new file mode 100644 index 0000000..12f2117 --- /dev/null +++ b/server/src/Validation/Category.hs @@ -0,0 +1,27 @@ +module Validation.Category + ( createCategory + , editCategory + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Validation.Category as CategoryValidation +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) + +createCategory :: CreateCategoryForm -> Validation Text CreateCategory +createCategory form = + CreateCategory + <$> CategoryValidation.name (_createCategoryForm_name form) + <*> CategoryValidation.color (_createCategoryForm_color form) + +editCategory :: EditCategoryForm -> Validation Text EditCategory +editCategory form = + EditCategory + <$> V.Success (_editCategoryForm_id form) + <*> CategoryValidation.name (_editCategoryForm_name form) + <*> CategoryValidation.color (_editCategoryForm_color form) diff --git a/server/src/Validation/Income.hs b/server/src/Validation/Income.hs new file mode 100644 index 0000000..5e034d1 --- /dev/null +++ b/server/src/Validation/Income.hs @@ -0,0 +1,27 @@ +module Validation.Income + ( createIncome + , editIncome + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..)) +import qualified Common.Validation.Income as IncomeValidation +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) + +createIncome :: CreateIncomeForm -> Validation Text CreateIncome +createIncome form = + CreateIncome + <$> IncomeValidation.amount (_createIncomeForm_amount form) + <*> IncomeValidation.date (_createIncomeForm_date form) + +editIncome :: EditIncomeForm -> Validation Text EditIncome +editIncome form = + EditIncome + <$> V.Success (_editIncomeForm_id form) + <*> IncomeValidation.amount (_editIncomeForm_amount form) + <*> IncomeValidation.date (_editIncomeForm_date form) diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs new file mode 100644 index 0000000..20e370e --- /dev/null +++ b/server/src/Validation/Payment.hs @@ -0,0 +1,33 @@ +module Validation.Payment + ( createPayment + , editPayment + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CategoryId, CreatePaymentForm (..), + EditPaymentForm (..)) +import qualified Common.Validation.Payment as PaymentValidation +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) + +createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment +createPayment categories form = + CreatePayment + <$> PaymentValidation.name (_createPaymentForm_name form) + <*> PaymentValidation.cost (_createPaymentForm_cost form) + <*> PaymentValidation.date (_createPaymentForm_date form) + <*> PaymentValidation.category categories (_createPaymentForm_category form) + <*> V.Success (_createPaymentForm_frequency form) + +editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment +editPayment categories form = + EditPayment + <$> V.Success (_editPaymentForm_id form) + <*> PaymentValidation.name (_editPaymentForm_name form) + <*> PaymentValidation.cost (_editPaymentForm_cost form) + <*> PaymentValidation.date (_editPaymentForm_date form) + <*> PaymentValidation.category categories (_editPaymentForm_category form) + <*> V.Success (_editPaymentForm_frequency form) diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs new file mode 100644 index 0000000..dc86122 --- /dev/null +++ b/server/src/Validation/SignIn.hs @@ -0,0 +1,16 @@ +module Validation.SignIn + ( signIn + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model (SignInForm (..)) +import qualified Common.Validation.SignIn as SignInValidation +import Model.SignIn (SignIn (..)) + +signIn :: SignInForm -> Validation Text SignIn +signIn form = + SignIn + <$> SignInValidation.email (_signInForm_email form) + <*> SignInValidation.password (_signInForm_password form) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..3fe224f --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,124 @@ +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) + +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import Conf (Conf) +import qualified Conf as Conf +import Model.IncomeResource (IncomeResource (..)) +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer +import Resource (Status (..), groupByStatus, statuses) + +mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Msg.get Msg.App_Title + , " − " + , Msg.get Msg.WeeklyReport_Title + ] + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end + } + +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + T.intercalate "\n" $ + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition + , operations conf users paymentsGroupedByStatus incomesGroupedByStatus + ] + where + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes + +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = + T.intercalate "\n" . map formatPayer $ payers + where + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition + formatPayer p = T.concat + [ " * " + , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users + , " + " + , Format.price (Conf.currency conf) $ _exceedingPayer_amount p + , "\n" + ] + +operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text +operations conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Msg.get Msg.WeeklyReport_Empty + else + T.intercalate "\n" . catMaybes . concat $ + [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses + , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses + ] + +paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" * " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..ae7a266 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +module View.Page + ( page + ) where + +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) + +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A + +import Common.Model (Init) +import qualified Common.Msg as Msg + +page :: Maybe Init -> Text +page init = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Msg.get Msg.App_Title) + script ! src "/javascript/main.js" $ "" + script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ "" + jsonScript "init" init + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" + link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" + H.body $ do + H.div ! A.class_ "spinner" $ "" + + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json diff --git a/sharedCost.cabal b/sharedCost.cabal deleted file mode 100644 index befd71b..0000000 --- a/sharedCost.cabal +++ /dev/null @@ -1,124 +0,0 @@ -name: sharedCost -version: 0.1 -license: GPL-3 -license-file: LICENSE -author: Joris -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable sharedCost - main-is: Main.hs - hs-source-dirs: src/server - default-language: Haskell2010 - ghc-options: -Wall -Werror - build-depends: base < 5 - , scotty - , wai - , wai-middleware-static - , http-types - , http-conduit - , time - , text - , blaze-builder - , cookie - , bytestring - , monad-logger - , resourcet - , transformers - , blaze-html - , clay - , aeson - , clientsession - , uuid - , mtl - , lens - , parsec - , unordered-containers - , containers - , email-validate - , config-manager - , process - , sqlite-simple - - , random - , process - , filepath - , base64-bytestring - -- , mime-mail - - other-modules: Conf - , Controller.Category - , Controller.Income - , Controller.Index - , Controller.Payment - , Controller.SignIn - , Cookie - , Design.LoggedIn.Home.Table - , Design.LoggedIn.Stat - , Design.LoggedIn.Table - , Design.Media - , Design.SignIn - , Design.Tooltip - , Design.Color - , Design.Constants - , Design.Dialog - , Design.Errors - , Design.Form - , Design.Global - , Design.Header - , Design.Helper - , Design.LoggedIn - , Design.LoggedIn.Home - , Design.LoggedIn.Home.Header - , Design.LoggedIn.Home.Pages - , Job.Daemon - , Job.Frequency - , Job.Kind - , Job.Model - , Job.MonthlyPayment - , Job.WeeklyReport - , Json - , LoginSession - , MimeMail - , Model.Category - , Model.Frequency - , Model.Income - , Model.Init - , Model.Json.Category - , Model.Json.Conf - , Model.Json.CreateCategory - , Model.Json.CreateIncome - , Model.Json.CreatePayment - , Model.Json.EditCategory - , Model.Json.EditIncome - , Model.Json.EditPayment - , Model.Json.Income - , Model.Json.Init - , Model.Json.MessagePart - , Model.Json.Payment - , Model.Json.PaymentCategory - , Model.Json.Translation - , Model.Json.User - , Model.Mail - , Model.Message - , Model.Message.Key - , Model.Message.Lang - , Model.Message.Parts - , Model.Message.Translations - , Model.Payment - , Model.PaymentCategory - , Model.Query - , Model.SignIn - , Model.UUID - , Model.User - , Resource - , Secure - , SendMail - , Utils.Text - , Utils.Time - , View.Format - , View.Mail.SignIn - , View.Mail.WeeklyReport - , View.Page diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 83935d8..0000000 --- a/shell.nix +++ /dev/null @@ -1,13 +0,0 @@ -with import <nixpkgs> {}; { - env = stdenv.mkDerivation { - name = "env"; - buildInputs = with pkgs; [ - elmPackages.elm - nodePackages.nodemon - sqlite - stack - tmux - tmuxinator - ]; - }; -} diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm deleted file mode 100644 index 693f362..0000000 --- a/src/client/Chart/Api.elm +++ /dev/null @@ -1,41 +0,0 @@ -module Chart.Api exposing - ( from - , withSize - , withTitle - , withOrdinate - , toHtml - ) - -import Html exposing (Html) -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Chart.View as Chart - -from : List String -> List Serie -> Chart -from keys series = - { keys = keys - , series = series - , size = { x = 600, y = 400 } - , title = "" - , scaleColor = "#DDDDDD" - , formatOrdinate = toString - , ordinateLines = 5 - } - -withSize : Vec2 -> Chart -> Chart -withSize size chart = { chart | size = size } - -withTitle : String -> Chart -> Chart -withTitle title chart = { chart | title = title } - -withOrdinate : Int -> (Float -> String) -> Chart -> Chart -withOrdinate lines format chart = - { chart - | formatOrdinate = format - , ordinateLines = lines - } - -toHtml : Chart -> Html msg -toHtml chart = Chart.view chart diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm deleted file mode 100644 index b5c176f..0000000 --- a/src/client/Chart/Model.elm +++ /dev/null @@ -1,73 +0,0 @@ -module Chart.Model exposing - ( Chart - , Serie - , maxScale - , Vec2 - , View - , mkView - , bounds - ) - -import List.Extra as List - -type alias Chart = - { keys : List String - , series : List Serie - , size : Vec2 - , title : String - , scaleColor : String - , formatOrdinate : Float -> String - , ordinateLines : Int - } - -type alias Serie = - { values : List Float - , color : String - , label : String - } - -maxScale : Chart -> Float -maxScale { keys, series } = - List.range 0 (List.length keys - 1) - |> List.map (\i -> - series - |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values) - |> List.maximum - |> Maybe.withDefault 0 - ) - |> List.maximum - |> Maybe.withDefault 0 - |> upperBound - -upperBound : Int -> Float -upperBound n = toFloat (upperBoundInt 0 n) - -upperBoundInt : Int -> Int -> Int -upperBoundInt count n = - if n < 10 - then - (n + 1) * (10 ^ count) - else - upperBoundInt (count + 1) (n // 10) - -type alias Vec2 = - { x : Float - , y : Float - } - -type alias View = - { fx : Float -> Float - , fy : Float -> Float - } - -mkView : Vec2 -> Vec2 -> View -mkView p1 p2 = - { fx = \x -> p1.x + x * (p2.x - p1.x) - , fy = \y -> p1.y + y * (p2.y - p1.y) - } - -bounds : View -> (Vec2, Vec2) -bounds { fx, fy } = - ( { x = fx 0, y = fy 0 } - , { x = fx 1, y = fy 1 } - ) diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm deleted file mode 100644 index af8b4b7..0000000 --- a/src/client/Chart/View.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Chart.View exposing - ( view - ) - -import Html exposing (Html) -import List.Extra as List -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Utils.List as List - -view : Chart -> Html msg -view chart = - let { size, title, series } = chart - titleHeight = 100 - captionHeight = 50 - in svg - [ width << toString <| size.x - , height << toString <| size.y - , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y)) - ] - ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ] - ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart - ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series - ) - -renderTitle : View -> String -> Svg msg -renderTitle view title = - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - , fontSize "20" - ] - [ text title ] - -renderSeriesAndScales : View -> Chart -> List (Svg msg) -renderSeriesAndScales view chart = - let { keys, series, scaleColor, formatOrdinate } = chart - (p1, p2) = Chart.bounds view - ordinateWidth = 100 - abscissaHeight = 60 - maxScale = Chart.maxScale chart - in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale - ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor - ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor - ) - -renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg) -renderOrdinates view formatOrdinate maxScale = - ordinates - |> List.map (\l -> - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy l - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text << formatOrdinate <| (1 - l) * maxScale ] - ) - - -renderAbscissas : View -> List String -> String -> List (Svg msg) -renderAbscissas view keys scaleColor = - let count = List.length keys - in ( abscissasXPositions keys - |> List.map (\(xPos, key) -> - [ text_ - [ x << toString <| view.fx xPos - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text key ] - , line - [ x1 << toString <| view.fx xPos - , y1 << toString <| view.fy 0 - , x2 << toString <| view.fx xPos - , y2 << toString <| view.fy 0.2 - , stroke scaleColor - ] - [] - ] - ) - |> List.concat - ) - -renderSeries : View -> List Serie -> Float -> String -> List (Svg msg) -renderSeries view series maxScale scaleColor = - ( renderHorizontalLines view series scaleColor - ++ renderPoints view series maxScale - ) - -renderHorizontalLines : View -> List Serie -> String -> List (Svg msg) -renderHorizontalLines view series scaleColor = - ordinates - |> List.map (\l -> - line - [ x1 << toString <| view.fx 0 - , y1 << toString <| view.fy l - , x2 << toString <| view.fx 1 - , y2 << toString <| view.fy l - , stroke scaleColor - ] - [] - ) - -renderPoints : View -> List Serie -> Float -> List (Svg msg) -renderPoints view series maxScale = - series - |> List.map (\serie -> - let points = - abscissasXPositions serie.values - |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale }) - in [ renderLines view serie.color points - , List.map (renderPoint view serie.color) points - ] - |> List.concat - ) - |> List.concat - -renderLines : View -> String -> List Vec2 -> List (Svg msg) -renderLines view color points = - List.links points - |> List.map (\(p1, p2) -> - line - [ x1 << toString <| view.fx p1.x - , y1 << toString <| view.fy p1.y - , x2 << toString <| view.fx p2.x - , y2 << toString <| view.fy p2.y - , stroke color - ] - [] - ) - -renderPoint : View -> String -> Vec2 -> Svg msg -renderPoint view color pos = - circle - [ cx << toString <| view.fx pos.x - , cy << toString <| view.fy pos.y - , r "4" - , fill color - ] - [] - -abscissasXPositions : List a -> List (Float, a) -abscissasXPositions xs = - let count = List.length xs - in xs - |> List.zip (List.range 1 (count + 1)) - |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x)) - -ordinates : List Float -ordinates = - let count = 10 - in List.range 0 (count - 1) - |> List.map (\l -> toFloat l / (toFloat count - 1)) - -renderCaptions : View -> List Serie -> List (Svg msg) -renderCaptions view series = - let count = List.length series - in series - |> List.zip (List.range 1 (List.length series)) - |> List.map (\(i, serie) -> - renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie - ) - |> List.concat - -renderCaption : Vec2 -> Serie -> List (Svg msg) -renderCaption point { label, color } = - [ text_ - [ x << toString <| point.x - , y << toString <| point.y - , textAnchor "middle" - , dominantBaseline "middle" - , fill color - , fontSize "18" - ] - [ text label ] - ] diff --git a/src/client/Dialog.elm b/src/client/Dialog.elm deleted file mode 100644 index a7e059a..0000000 --- a/src/client/Dialog.elm +++ /dev/null @@ -1,165 +0,0 @@ -module Dialog exposing - ( Msg(..) - , Model - , Config - , init - , update - , view - ) - -import Platform.Cmd exposing (Cmd) -import Task exposing (Task) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - --- Model - -type alias Model model modelMsg msg = - { config : Maybe (Config model msg) - , mapMsg : Msg model modelMsg msg -> msg - , model : model - } - -type alias Config model msg = - { className : String - , title : String - , body : model -> Html msg - , confirm : String - , confirmMsg : model -> msg - , undo : String - } - -init : model -> (Msg model modelMsg msg -> msg) -> Model model modelMsg msg -init model mapMsg = - { config = Nothing - , mapMsg = mapMsg - , model = model - } - --- Update - -type Msg model modelMsg msg = - NoOp - | Update modelMsg - | UpdateAndClose msg - | OpenWithUpdate (Config model msg) modelMsg - | Open (Config model msg) - | Close - -update : (modelMsg -> model -> (model, Cmd modelMsg)) -> Msg model modelMsg msg -> model -> Model model modelMsg msg -> (Model model modelMsg msg, Cmd msg) -update updateModel msg baseModel model = - case msg of - NoOp -> - ( model - , Cmd.none - ) - - Update modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model | model = newModel } - , Cmd.map (model.mapMsg << Update) effects - ) - - UpdateAndClose msg -> - ( { model | config = Nothing } - , Task.perform (always msg) (Task.succeed msg) - ) - - OpenWithUpdate config modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model - | model = newModel - , config = Just config - } - , Cmd.map (model.mapMsg << Update) effects - ) - - Open config -> - ( { model | config = Just config } - , Cmd.none - ) - - Close -> - ( { model | config = Nothing } - , Cmd.none - ) - --- View - -view : Model model modelMsg msg -> Html msg -view { mapMsg, config, model } = - let isVisible = - case config of - Just _ -> True - Nothing -> False - in div - [ class "dialog" ] - [ curtain mapMsg isVisible - , case config of - Nothing -> - text "" - Just c -> - dialog model mapMsg c - ] - -curtain : (Msg model modelMsg msg -> msg) -> Bool -> Html msg -curtain mapMsg isVisible = - div - [ class "curtain" - , style - [ ("position", "fixed") - , ("top", "0") - , ("left", "0") - , ("width", "100%") - , ("height", "100%") - , ("background-color", "rgba(0, 0, 0, 0.5)") - , ("z-index", if isVisible then "1000" else "-1") - , ("opacity", if isVisible then "1" else "0") - , ("transition", "all 0.2s ease") - ] - , onClick (mapMsg Close) - ] - [] - -dialog : model -> (Msg model modelMsg msg -> msg) -> Config model msg -> Html msg -dialog model mapMsg { className, title, body, confirm, confirmMsg, undo } = - div - [ class ("content " ++ className) - , style - [ ("position", "fixed") - , ("top", "25%") - , ("left", "50%") - , ("transform", "translate(-50%, -25%)") - , ("z-index", "1000") - , ("background-color", "white") - , ("padding", "20px") - , ("border-radius", "5px") - , ("box-shadow", "0px 0px 15px rgba(0, 0, 0, 0.5)") - ] - ] - [ h1 [] [ text title ] - , body model - , div - [ style - [ ("float", "right") - ] - ] - [ button - [ class "confirm" - , onClick (confirmMsg model) - , style - [ ("margin-right", "15px") - ] - ] - [ text confirm ] - , button - [ class "undo" - , onClick (mapMsg Close) - ] - [ text undo ] - ] - ] diff --git a/src/client/Dialog/AddCategory/Model.elm b/src/client/Dialog/AddCategory/Model.elm deleted file mode 100644 index 3b70482..0000000 --- a/src/client/Dialog/AddCategory/Model.elm +++ /dev/null @@ -1,54 +0,0 @@ -module Dialog.AddCategory.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import Dict - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Category exposing (Categories, Category, CategoryId) -import Model.Translations exposing (Translations) -import Validation -import View.Date as Date - -type alias Model = - { id : Maybe CategoryId - , name : String - , color : String - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> List (String, Field) -initialAdd translations = - [ ("color", Field.string "#000000") - ] - -initialClone : Translations -> Category -> List (String, Field) -initialClone translations category = - [ ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -initialEdit : Translations -> CategoryId -> Category -> List (String, Field) -initialEdit translations categoryId category = - [ ("id", Field.string (toString categoryId)) - , ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "color" Validation.color) diff --git a/src/client/Dialog/AddCategory/View.elm b/src/client/Dialog/AddCategory/View.elm deleted file mode 100644 index dc55b60..0000000 --- a/src/client/Dialog/AddCategory/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddCategory.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "categoryDialog" - , title = getMessage loggedData.translations title - , body = \model -> addCategoryForm loggedData model.addCategory - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addCategory - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "categoryname" (DialogMsg.AddCategoryMsg (Form.Reset initialForm)))) ] - ) - [ buttonContent ] - -addCategoryForm : LoggedData -> Form String AddCategory.Model -> Html Msg -addCategoryForm loggedData addCategory = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddCategoryMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addCategory "category" "name" - , htmlMap <| Form.colorInput loggedData.translations addCategory "category" "color" - , Form.hiddenSubmit (submitForm addCategory) - ] - -submitForm : Form String AddCategory.Model -> Msg -submitForm addCategory = - case Form.getOutput addCategory of - Just data -> - case data.id of - Just categoryId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditCategory categoryId (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit diff --git a/src/client/Dialog/AddIncome/Model.elm b/src/client/Dialog/AddIncome/Model.elm deleted file mode 100644 index 5e2ccf1..0000000 --- a/src/client/Dialog/AddIncome/Model.elm +++ /dev/null @@ -1,53 +0,0 @@ -module Dialog.AddIncome.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Translations exposing (Translations) -import Model.Income exposing (Income, IncomeId) - -type alias Model = - { id : Maybe IncomeId - , amount : Int - , date : Date - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> Date -> List (String, Field) -initialAdd translations date = - [ ("date", Field.string (Date.shortView date translations)) - ] - -initialClone : Translations -> Date -> Income -> List (String, Field) -initialClone translations date income = - [ ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView date translations)) - ] - -initialEdit : Translations -> IncomeId -> Income -> List (String, Field) -initialEdit translations incomeId income = - [ ("id", Field.string (toString incomeId)) - , ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations)) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 0))) - (Validate.field "date" Validation.date) diff --git a/src/client/Dialog/AddIncome/View.elm b/src/client/Dialog/AddIncome/View.elm deleted file mode 100644 index b413308..0000000 --- a/src/client/Dialog/AddIncome/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddIncome.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "incomeDialog" - , title = getMessage loggedData.translations title - , body = \model -> addIncomeForm loggedData model.addIncome - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addIncome - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ] - ) - [ buttonContent ] - -addIncomeForm : LoggedData -> Form String AddIncome.Model -> Html Msg -addIncomeForm loggedData addIncome = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddIncomeMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addIncome "income" "amount" - , htmlMap <| Form.textInput loggedData.translations addIncome "income" "date" - , Form.hiddenSubmit (submitForm addIncome) - ] - -submitForm : Form String AddIncome.Model -> Msg -submitForm addIncome = - case Form.getOutput addIncome of - Just data -> - case data.id of - Just incomeId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditIncome incomeId data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateIncome data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddIncomeMsg <| Form.Submit diff --git a/src/client/Dialog/AddPayment/Model.elm b/src/client/Dialog/AddPayment/Model.elm deleted file mode 100644 index 07e7cbb..0000000 --- a/src/client/Dialog/AddPayment/Model.elm +++ /dev/null @@ -1,70 +0,0 @@ -module Dialog.AddPayment.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Category as Category exposing (Categories, CategoryId) -import Model.Frequency as Frequency -import Model.Payment as Payment exposing (Payment, PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Translations exposing (Translations) - -type alias Model = - { id : Maybe PaymentId - , name : String - , cost : Int - , date : Date - , category : CategoryId - , frequency : Frequency - } - -init : Form String Model -init = Form.initial [] (validation Category.empty) - -initialAdd : Translations -> Date -> Frequency -> List (String, Field) -initialAdd translations date frequency = - [ ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString frequency)) - , ("category", Field.string "") - ] - -initialClone : Translations -> Date -> Maybe CategoryId -> Payment -> List (String, Field) -initialClone translations date category payment = - [ ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -initialEdit : Translations -> Maybe CategoryId -> Payment -> List (String, Field) -initialEdit translations category payment = - [ ("id", Field.string (toString payment.id)) - , ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView payment.date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -validation : Categories -> Validation String Model -validation categories = - Validate.map6 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "cost" Validation.cost) - (Validate.field "date" Validation.date) - (Validate.field "category" (Validation.category categories)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/Dialog/AddPayment/View.elm b/src/client/Dialog/AddPayment/View.elm deleted file mode 100644 index 584adcd..0000000 --- a/src/client/Dialog/AddPayment/View.elm +++ /dev/null @@ -1,95 +0,0 @@ -module Dialog.AddPayment.View exposing - ( button - ) - -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Events exposing (onSubmitPrevDefault) -import View.Form as Form - -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Msg as LoggedInMsg -import Msg exposing (Msg) - -import Model.Category exposing (Categories) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "paymentDialog" - , title = getMessage loggedData.translations title - , body = \model -> addPaymentForm loggedData model.addPayment - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ class "addPayment" - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "paymentname" (DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories <| Form.Reset initialForm))) - ] - ) - [ buttonContent ] - -addPaymentForm : LoggedData -> Form String AddPayment.Model -> Html Msg -addPaymentForm loggedData addPayment = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories) - categoryOptions = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - |> List.map (\(id, category) -> (toString id, category.name)) - in Html.form - [ class "addPayment" - , onSubmitPrevDefault Msg.NoOp - ] - [ htmlMap <| Form.textInput loggedData.translations addPayment "payment" "name" - , htmlMap <| Form.textInput loggedData.translations addPayment "payment" "cost" - , if (Form.getFieldAsString "frequency" addPayment).value == Just (toString Punctual) - then htmlMap <| Form.textInput loggedData.translations addPayment "payment" "date" - else text "" - , htmlMap <| Form.selectInput loggedData.translations addPayment "payment" "category" categoryOptions - - , htmlMap <| Form.radioInputs loggedData.translations addPayment "payment" "frequency" [ toString Punctual, toString Monthly ] - , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment) - ] - -submitForm : Categories -> PaymentCategories -> Form String AddPayment.Model -> Msg -submitForm categories paymentCategories addPayment = - case Form.getOutput addPayment of - Just data -> - case data.id of - Just paymentId -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.EditPayment paymentId (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.CreatePayment (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit diff --git a/src/client/Dialog/Model.elm b/src/client/Dialog/Model.elm deleted file mode 100644 index ff8bc57..0000000 --- a/src/client/Dialog/Model.elm +++ /dev/null @@ -1,23 +0,0 @@ -module Dialog.Model exposing - ( Model - , init - ) - -import Form exposing (Form) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddCategory.Model as AddCategory - -type alias Model = - { addPayment : Form String AddPayment.Model - , addIncome : Form String AddIncome.Model - , addCategory : Form String AddCategory.Model - } - -init : Model -init = - { addPayment = AddPayment.init - , addIncome = AddIncome.init - , addCategory = AddCategory.init - } diff --git a/src/client/Dialog/Msg.elm b/src/client/Dialog/Msg.elm deleted file mode 100644 index 68ed146..0000000 --- a/src/client/Dialog/Msg.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Dialog.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -type Msg = - NoOp - | Init String Msg - | AddPaymentMsg Categories PaymentCategories Form.Msg - | AddIncomeMsg Form.Msg - | AddCategoryMsg Form.Msg diff --git a/src/client/Dialog/Update.elm b/src/client/Dialog/Update.elm deleted file mode 100644 index 3915548..0000000 --- a/src/client/Dialog/Update.elm +++ /dev/null @@ -1,74 +0,0 @@ -module Dialog.Update exposing - ( update - ) - -import Dom exposing (Id) -import Form exposing (Form) -import Form.Field as Field -import Task - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddPayment.Model as AddPayment -import Dialog.Model as Dialog -import Dialog.Msg as Dialog - -import Model.Category exposing (Categories) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -update : Dialog.Msg -> Dialog.Model -> (Dialog.Model, Cmd Dialog.Msg) -update msg model = - case msg of - - Dialog.NoOp -> - ( model - , Cmd.none - ) - - Dialog.Init inputId dialogMsg -> - update dialogMsg model - |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId]) - - Dialog.AddPaymentMsg categories paymentCategories formMsg -> - ( { model - | addPayment = - Form.update (AddPayment.validation categories) formMsg model.addPayment - |> updateCategory categories paymentCategories formMsg - } - , Cmd.none - ) - - Dialog.AddIncomeMsg formMsg -> - ( { model - | addIncome = Form.update AddIncome.validation formMsg model.addIncome - } - , Cmd.none - ) - - Dialog.AddCategoryMsg formMsg -> - ( { model - | addCategory = Form.update AddCategory.validation formMsg model.addCategory - } - , Cmd.none - ) - -inputFocus : Id -> Cmd Dialog.Msg -inputFocus id = - Dom.focus id - |> Task.map (always Dialog.NoOp) - |> Task.onError (\_ -> Task.succeed Dialog.NoOp) - |> Task.perform (always Dialog.NoOp) - -updateCategory : Categories -> PaymentCategories -> Form.Msg -> (Form String AddPayment.Model -> Form String AddPayment.Model) -updateCategory categories paymentCategories formMsg = - case formMsg of - Form.Input "name" Form.Text (Field.String paymentName) -> - case PaymentCategory.search paymentName paymentCategories of - Just category -> - Form.update - (AddPayment.validation categories) - (Form.Input "category" Form.Text (Field.String <| toString category)) - Nothing -> - identity - _ -> - identity diff --git a/src/client/Init.elm b/src/client/Init.elm deleted file mode 100644 index d87e870..0000000 --- a/src/client/Init.elm +++ /dev/null @@ -1,30 +0,0 @@ -module Init exposing - ( Init - , decoder - ) - -import Time exposing (..) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import Model.Size exposing (..) - -type alias Init = - { time : Time - , translations : Translations - , conf : Conf - , result : InitResult - , windowSize : Size - } - -decoder : Decoder Init -decoder = - Decode.map5 Init - (Decode.field "time" Decode.float) - (Decode.field "translations" translationsDecoder) - (Decode.field "conf" confDecoder) - (Decode.field "result" initResultDecoder) - (Decode.field "windowSize" sizeDecoder) diff --git a/src/client/LoggedData.elm b/src/client/LoggedData.elm deleted file mode 100644 index e048247..0000000 --- a/src/client/LoggedData.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedData exposing - ( LoggedData - , build - ) - -import Time exposing (Time) - -import Msg exposing (Msg) - -import Model exposing (Model) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.Payment exposing (Payments) -import Model.User exposing (Users, UserId) -import Model.Income exposing (Incomes) -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -import LoggedIn.Model as LoggedInModel - -type alias LoggedData = - { currentTime : Time - , translations : Translations - , conf : Conf - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -build : Time -> Translations -> Conf -> LoggedInModel.Model -> LoggedData -build currentTime translations conf loggedIn = - { currentTime = currentTime - , translations = translations - , conf = conf - , users = loggedIn.users - , me = loggedIn.me - , payments = loggedIn.payments - , incomes = loggedIn.incomes - , categories = loggedIn.categories - , paymentCategories = loggedIn.paymentCategories - } diff --git a/src/client/LoggedIn/Category/Table.elm b/src/client/LoggedIn/Category/Table.elm deleted file mode 100644 index 9405e57..0000000 --- a/src/client/LoggedIn/Category/Table.elm +++ /dev/null @@ -1,123 +0,0 @@ -module LoggedIn.Category.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Category as Category exposing (CategoryId, Category) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let categories = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) categories) - , if List.isEmpty (Dict.toList loggedData.categories) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoCategories" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell category" ] [ text <| getMessage loggedData.translations "Color" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (CategoryId, Category) -> Html Msg -paymentLine loggedData (categoryId, category) = - div - [ class "row" ] - [ div - [ class "cell category" ] - [ text category.name ] - , div - [ class "cell category" ] - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.color ] - ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddCategory.button - loggedData - (AddCategory.initialClone loggedData.translations category) - "CloneCategory" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ AddCategory.button - loggedData - (AddCategory.initialEdit loggedData.translations categoryId category) - "EditCategory" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if PaymentCategory.isCategoryUnused categoryId loggedData.paymentCategories - then - let dialogConfig = - { className = "deleteCategoryDialog" - , title = getMessage loggedData.translations "ConfirmCategoryDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteCategory categoryId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - else - span - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "UsedCategory") ) - [ FontAwesome.trash Color.silver 18 ] - ] - ] diff --git a/src/client/LoggedIn/Category/View.elm b/src/client/LoggedIn/Category/View.elm deleted file mode 100644 index bba51b7..0000000 --- a/src/client/LoggedIn/Category/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Category.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import LoggedData exposing (LoggedData) - -import Msg exposing (Msg) - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import LoggedIn.Category.Table as Table - -import Model.Translations exposing (getMessage, getParamMessage) - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "categories" ] - [ div - [ class "titleButton withMargin" ] - [ h1 [] [ text <| getMessage loggedData.translations "Categories" ] - , AddCategory.button - loggedData - (AddCategory.initialAdd loggedData.translations) - "AddCategory" - (text (getMessage loggedData.translations "AddCategory")) - Nothing - ] - , Table.view loggedData - ] diff --git a/src/client/LoggedIn/Home/Header/View.elm b/src/client/LoggedIn/Home/Header/View.elm deleted file mode 100644 index 14d90d7..0000000 --- a/src/client/LoggedIn/Home/Header/View.elm +++ /dev/null @@ -1,105 +0,0 @@ -module LoggedIn.Home.Header.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import String -import Dict -import Date - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import Model.Translations exposing (getParamMessage) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.Translations exposing (getMessage) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers -import LoggedIn.View.Format as Format -import View.Plural exposing (plural) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg -view loggedData { search } payments frequency = - let currentDate = Date.fromTime loggedData.currentTime - in Html.div - [ class "header" ] - [ div - [ class "payerAndAdd" ] - [ ExceedingPayers.view loggedData - , AddPayment.button - loggedData - (AddPayment.initialAdd loggedData.translations currentDate frequency) - "AddPayment" - (text (getMessage loggedData.translations "AddPayment")) - Nothing - ] - , Html.div - [ class "searchLine" ] - [ searchForm loggedData search ] - , infos loggedData payments - ] - -searchForm : LoggedData -> Form String Home.Search -> Html Msg -searchForm loggedData search = - Html.map (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.SearchMsg) <| - Html.form - [ onSubmitPrevDefault Form.NoOp ] - [ Form.textInput loggedData.translations search "search" "name" - , if List.isEmpty (Payment.monthly loggedData.payments) - then text "" - else Form.radioInputs loggedData.translations search "search" "frequency" [ toString Punctual, toString Monthly ] - ] - -infos : LoggedData -> Payments -> Html Msg -infos loggedData payments = - let paymentsCount = List.length payments - in if paymentsCount == 0 - then text "" - else - let count = plural loggedData.translations (List.length payments) "Payment" "Payments" - sum = paymentsSum loggedData.conf payments - in div - [ class "infos" ] - [ span - [ class "total" ] - [ text <| getParamMessage [ count, sum ] loggedData.translations "Worth" ] - , span - [ class "partition" ] - [ text <| paymentsPartition loggedData payments ] - ] - -paymentsPartition : LoggedData -> Payments -> String -paymentsPartition loggedData payments = - String.join - ", " - ( loggedData.users - |> Dict.toList - |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments)) - |> List.filter (\(sum, _) -> sum > 0) - |> List.sortBy Tuple.first - |> List.reverse - |> List.map (\(sum, user) -> - getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By" - ) - ) - -paymentsSum : Conf -> Payments -> String -paymentsSum conf payments = - payments - |> List.map .cost - |> List.sum - |> Format.price conf diff --git a/src/client/LoggedIn/Home/Model.elm b/src/client/LoggedIn/Home/Model.elm deleted file mode 100644 index e5381f6..0000000 --- a/src/client/LoggedIn/Home/Model.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Model exposing - ( Model - , Search - , init - , searchInitial - , validation - ) - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Frequency as Frequency -import Model.Payer exposing (Payers) -import Model.Payment as Payment exposing (PaymentId, Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.User exposing (Users, UserId) - -type alias Model = - { punctualPage : Int - , monthlyPage : Int - , search : Form String Search - } - -type alias Search = - { name : Maybe String - , frequency : Frequency - } - -init : Model -init = - { punctualPage = 1 - , monthlyPage = 1 - , search = Form.initial (searchInitial Punctual) validation - } - -searchInitial : Frequency -> List (String, Field) -searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ] - -validation : Validation String Search -validation = - Validate.map2 Search - (Validate.field "name" (Validate.maybe Validate.string)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/LoggedIn/Home/Msg.elm b/src/client/LoggedIn/Home/Msg.elm deleted file mode 100644 index 69f15ad..0000000 --- a/src/client/LoggedIn/Home/Msg.elm +++ /dev/null @@ -1,13 +0,0 @@ -module LoggedIn.Home.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) - -type Msg = - NoOp - | UpdatePage Int - | SearchMsg Form.Msg diff --git a/src/client/LoggedIn/Home/Update.elm b/src/client/LoggedIn/Home/Update.elm deleted file mode 100644 index 06c2c7e..0000000 --- a/src/client/LoggedIn/Home/Update.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Update exposing - ( update - ) - -import Form exposing (Form) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import Model.Frequency as Frequency exposing (Frequency(..)) - -update : LoggedData -> Home.Msg -> Home.Model -> (Home.Model, Cmd Home.Msg) -update loggedData msg model = - case msg of - - Home.NoOp -> - ( model - , Cmd.none - ) - - Home.UpdatePage page -> - ( updatePage page model - , Cmd.none - ) - - Home.SearchMsg formMsg -> - let newModel = - case formMsg of - Form.Input "name" _ _ -> updatePage 1 model - _ -> model - in ( { model | search = Form.update Home.validation formMsg model.search } - , Cmd.none - ) - -updatePage : Int -> Home.Model -> Home.Model -updatePage page model = - let frequency = - Form.getFieldAsString "frequency" model.search - |> .value - |> Maybe.andThen Frequency.fromString - in case frequency of - Just Punctual -> { model | punctualPage = page } - Just Monthly -> { model | monthlyPage = page } - Nothing -> model diff --git a/src/client/LoggedIn/Home/View.elm b/src/client/LoggedIn/Home/View.elm deleted file mode 100644 index fba3f7c..0000000 --- a/src/client/LoggedIn/Home/View.elm +++ /dev/null @@ -1,43 +0,0 @@ -module LoggedIn.Home.View exposing - ( view - ) - -import Date -import Html exposing (..) -import Html.Attributes exposing (..) - -import Form -import Utils.Form as Form - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Header.View as Header -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.View.Paging as Paging -import LoggedIn.Home.View.Table as Table -import LoggedIn.Msg as LoggedInMsg -import Model.Payment as Payment -import Model.Frequency exposing (Frequency(..)) -import Msg exposing (Msg) - -view : LoggedData -> Home.Model -> Html Msg -view loggedData home = - let (name, frequency) = - case Form.getOutput home.search of - Just data -> (Maybe.withDefault "" data.name, data.frequency) - Nothing -> ("", Punctual) - payments = Payment.search name frequency loggedData.payments - page = - case frequency of - Punctual -> home.punctualPage - Monthly -> home.monthlyPage - in div - [ class "home" ] - [ Header.view loggedData home payments frequency - , Table.view loggedData home payments frequency page - , Paging.view - page - (List.length payments) - Msg.NoOp - (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage) - ] diff --git a/src/client/LoggedIn/Home/View/ExceedingPayers.elm b/src/client/LoggedIn/Home/View/ExceedingPayers.elm deleted file mode 100644 index 6f2439c..0000000 --- a/src/client/LoggedIn/Home/View/ExceedingPayers.elm +++ /dev/null @@ -1,45 +0,0 @@ -module LoggedIn.Home.View.ExceedingPayers exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.View.Format as Format - -import Model exposing (Model) -import Model.User exposing (getUserName) -import Model.Payment as Payment -import Model.Payer exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let payments = Payment.punctual loggedData.payments - exceedingPayers = getOrderedExceedingPayers loggedData.currentTime loggedData.users loggedData.incomes payments - in div - [ class "exceedingPayers" ] - ( if List.isEmpty exceedingPayers - then [ text <| getMessage loggedData.translations "PaymentsAreBalanced" ] - else (List.map (exceedingPayer loggedData) exceedingPayers) - ) - -exceedingPayer : LoggedData -> ExceedingPayer -> Html Msg -exceedingPayer loggedData payer = - span - [ class "exceedingPayer" ] - [ span - [ class "userName" ] - [ payer.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , span - [ class "amount" ] - [ text ("+ " ++ (Format.price loggedData.conf payer.amount)) ] - ] diff --git a/src/client/LoggedIn/Home/View/Paging.elm b/src/client/LoggedIn/Home/View/Paging.elm deleted file mode 100644 index dffe061..0000000 --- a/src/client/LoggedIn/Home/View/Paging.elm +++ /dev/null @@ -1,109 +0,0 @@ -module LoggedIn.Home.View.Paging exposing - ( view - ) - -import Color exposing (Color) - -import FontAwesome - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import LoggedData exposing (LoggedData) -import Model.Payment as Payment exposing (Payments, perPage) - -showedPages : Int -showedPages = 5 - -view : Int -> Int -> msg -> (Int -> msg) -> Html msg -view currentPage payments noOp pageMsg = - let maxPage = ceiling (toFloat payments / toFloat perPage) - pages = truncatePages currentPage (List.range 1 maxPage) - in if maxPage <= 1 - then - text "" - else - div - [ class "pages" ] - ( [ firstPage currentPage pageMsg - , previousPage currentPage noOp pageMsg - ] - ++ ( List.map (paymentsPage currentPage noOp pageMsg) pages) - ++ [ nextPage currentPage maxPage noOp pageMsg - , lastPage currentPage maxPage pageMsg - ] - ) - -truncatePages : Int -> List Int -> List Int -truncatePages currentPage pages = - let totalPages = List.length pages - showedLeftPages = ceiling ((toFloat showedPages - 1) / 2) - showedRightPages = floor ((toFloat showedPages - 1) / 2) - truncatedPages = - if currentPage <= showedLeftPages then - (List.range 1 showedPages) - else if currentPage > totalPages - showedRightPages then - (List.range (totalPages - showedPages + 1) totalPages) - else - (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages)) - in List.filter (flip List.member pages) truncatedPages - -firstPage : Int -> (Int -> msg) -> Html msg -firstPage currentPage pageMsg = - button - [ classList - [ ("page", True) - , ("disable", currentPage <= 1) - ] - , onClick (pageMsg 1) - ] - [ FontAwesome.fast_backward grey 13 ] - -previousPage : Int -> msg -> (Int -> msg) -> Html msg -previousPage currentPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage > 1 - then (pageMsg <| currentPage - 1) - else noOp - ] - [ FontAwesome.backward grey 13 ] - -nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg -nextPage currentPage maxPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage < maxPage - then (pageMsg <| currentPage + 1) - else noOp - ] - [ FontAwesome.forward grey 13 ] - -lastPage : Int -> Int -> (Int -> msg) -> Html msg -lastPage currentPage maxPage pageMsg = - button - [ class "page" - , onClick (pageMsg maxPage) - ] - [ FontAwesome.fast_forward grey 13 ] - -paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg -paymentsPage currentPage noOp pageMsg page = - let onCurrentPage = page == currentPage - in button - [ classList - [ ("page", True) - , ("current", onCurrentPage) - ] - , onClick <| - if onCurrentPage - then noOp - else pageMsg page - ] - [ text (toString page) ] - -grey : Color -grey = Color.greyscale 0.35 diff --git a/src/client/LoggedIn/Home/View/Table.elm b/src/client/LoggedIn/Home/View/Table.elm deleted file mode 100644 index f94bb19..0000000 --- a/src/client/LoggedIn/Home/View/Table.elm +++ /dev/null @@ -1,167 +0,0 @@ -module LoggedIn.Home.View.Table exposing - ( view - ) - -import Date exposing (Date) -import Dict exposing (..) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import LoggedIn.Home.Model as Home -import LoggedIn.View.Format as Format -import View.Date as Date - -import Model.Payment as Payment exposing (..) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) -import Model.User exposing (getUserName) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Int -> Html Msg -view loggedData homeModel payments frequency page = - let visiblePayments = - payments - |> List.drop ((page - 1) * perPage) - |> List.take perPage - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData frequency :: List.map (paymentLine loggedData homeModel frequency) visiblePayments ) - , if List.isEmpty visiblePayments - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoPayment" ] - else - text "" - ] - -headerLine : LoggedData -> Frequency -> Html Msg -headerLine loggedData frequency = - div - [ class "header" ] - [ div [ class "cell category" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell cost" ] [ text <| getMessage loggedData.translations "Cost" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "Payer" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "PaymentCategory" ] - , case frequency of - Punctual -> div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - Monthly -> text "" - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg -paymentLine loggedData homeModel frequency payment = - div - [ class "row" ] - [ div [ class "cell name" ] [ text payment.name ] - , div - [ classList - [ ("cell cost", True) - , ("refund", payment.cost < 0) - ] - ] - [ text (Format.price loggedData.conf payment.cost) ] - , div - [ class "cell user" ] - [ payment.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell category" ] - ( let mbCategory = - PaymentCategory.search payment.name loggedData.paymentCategories - |> Maybe.andThen (\category -> Dict.get category loggedData.categories) - in case mbCategory of - Just category -> - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.name ] - ] - Nothing -> - [] - ) - , case frequency of - Punctual -> - div - [ class "cell date" ] - [ span - [ class "shortDate" ] - [ text (Date.shortView payment.date loggedData.translations) ] - , span - [ class "longDate" ] - [ text (Date.longView payment.date loggedData.translations) ] - ] - Monthly -> - text "" - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialClone loggedData.translations currentDate category payment) - "ClonePayment" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialEdit loggedData.translations category payment) - "EditPayment" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let dialogConfig = - { className = "deletePaymentDialog" - , title = getMessage loggedData.translations "ConfirmPaymentDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeletePayment payment.id - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/Table.elm b/src/client/LoggedIn/Income/Table.elm deleted file mode 100644 index f10a552..0000000 --- a/src/client/LoggedIn/Income/Table.elm +++ /dev/null @@ -1,128 +0,0 @@ -module LoggedIn.Income.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Income as Income exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let incomes = - loggedData.incomes - |> Dict.toList - |> List.sortBy (.time << Tuple.second) - |> List.reverse - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) incomes) - , if List.isEmpty (Dict.toList loggedData.incomes) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoIncome" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell income" ] [ text <| getMessage loggedData.translations "Income" ] - , div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (IncomeId, Income) -> Html Msg -paymentLine loggedData (incomeId, income) = - div - [ class "row" ] - [ div - [ class "cell name" ] - [ income.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell income" ] - [ text (Format.price loggedData.conf income.amount) ] - , div - [ class "cell date" ] - [ text (Date.longView (Date.fromTime income.time) loggedData.translations) ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddIncome.button - loggedData - (AddIncome.initialClone loggedData.translations currentDate income) - "CloneIncome" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - AddIncome.button - loggedData - (AddIncome.initialEdit loggedData.translations incomeId income) - "EditIncome" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/View.elm b/src/client/LoggedIn/Income/View.elm deleted file mode 100644 index 85b0dc3..0000000 --- a/src/client/LoggedIn/Income/View.elm +++ /dev/null @@ -1,104 +0,0 @@ -module LoggedIn.Income.View exposing - ( view - ) - -import Dict -import Date -import Time exposing (Time) -import Task - -import FontAwesome - -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince) -import Model.Translations exposing (getMessage, getParamMessage) -import Model.Payer exposing (useIncomesFrom) -import Model.User exposing (UserId, User) -import Model.View as View - -import View.Date as Date -import LoggedIn.View.Format as Format -import View.Color as Color -import LoggedIn.Income.Table as Table - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "income" ] - [ div - [ class "withMargin" ] - [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of - Just since -> cumulativeIncomesView loggedData since - Nothing -> text "" - , div - [ class "titleButton" ] - [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ] - , AddIncome.button - loggedData - (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime)) - "AddIncome" - (text (getMessage loggedData.translations "AddIncome")) - Nothing - ] - ] - , Table.view loggedData - ] - -cumulativeIncomesView : LoggedData -> Time -> Html Msg -cumulativeIncomesView loggedData since = - let longDate = Date.longView (Date.fromTime since) loggedData.translations - in div - [] - [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ] - , ul - [] - ( Dict.toList loggedData.users - |> List.map (\(userId, user) -> - (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) - ) - |> List.sortBy Tuple.second - |> List.map (\(userName, cumulativeIncome) -> - li - [] - [ text userName - , text " − " - , text <| Format.price loggedData.conf cumulativeIncome - ] - ) - ) - ] - -incomeView : LoggedData -> (IncomeId, Income) -> Html Msg -incomeView loggedData (incomeId, income) = - li - [] - [ text <| Date.shortView (Date.fromTime income.time) loggedData.translations - , text " − " - , text <| Format.price loggedData.conf income.amount - , let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - [ FontAwesome.trash Color.chestnutRose 14 ] - ] diff --git a/src/client/LoggedIn/Model.elm b/src/client/LoggedIn/Model.elm deleted file mode 100644 index f4fad94..0000000 --- a/src/client/LoggedIn/Model.elm +++ /dev/null @@ -1,38 +0,0 @@ -module LoggedIn.Model exposing - ( Model - , init - ) - -import Time exposing (Time) - -import LoggedIn.Home.Model as Home -import LoggedIn.Stat.Model as Stat -import Model.Category exposing (Categories) -import Model.Income exposing (Incomes) -import Model.Init exposing (..) -import Model.Payment exposing (Payments) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.User exposing (Users, UserId) - -type alias Model = - { home : Home.Model - , stat : Stat.Model - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -init : Time -> Init -> Model -init time { users, me, payments, incomes, categories, paymentCategories } = - { home = Home.init - , stat = Stat.init time paymentCategories payments - , users = users - , me = me - , payments = payments - , incomes = incomes - , categories = categories - , paymentCategories = paymentCategories - } diff --git a/src/client/LoggedIn/Msg.elm b/src/client/LoggedIn/Msg.elm deleted file mode 100644 index d9b3bce..0000000 --- a/src/client/LoggedIn/Msg.elm +++ /dev/null @@ -1,26 +0,0 @@ -module LoggedIn.Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) - -import LoggedIn.Home.Msg as Home -import LoggedIn.Stat.Msg as Stat -import Model.Category exposing (CategoryId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Payment exposing (PaymentId) - -type Msg = - NoOp - | HomeMsg Home.Msg - | StatMsg Stat.Msg - | ValidateCreatePayment PaymentId String Int Date CategoryId Frequency - | ValidateEditPayment PaymentId String Int Date CategoryId Frequency - | ValidateDeletePayment PaymentId - | ValidateCreateIncome IncomeId Int Date - | ValidateEditIncome IncomeId Int Date - | ValidateDeleteIncome IncomeId - | ValidateCreateCategory CategoryId String String - | ValidateEditCategory CategoryId String String - | ValidateDeleteCategory CategoryId diff --git a/src/client/LoggedIn/Stat/Model.elm b/src/client/LoggedIn/Stat/Model.elm deleted file mode 100644 index bfc66f2..0000000 --- a/src/client/LoggedIn/Stat/Model.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Stat.Model exposing - ( Model - , init - , getPaymentsByMonthByCategory - ) - -import Date exposing (Month) -import List.Extra as List -import Time exposing (Time) - -import Model.Category exposing (CategoryId) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -type alias Model = - { paymentsByMonthByCategory : List ((Month, Int), List (CategoryId, Int)) - } - -init : Time -> PaymentCategories -> Payments -> Model -init currentTime paymentCategories payments = - { paymentsByMonthByCategory = getPaymentsByMonthByCategory currentTime paymentCategories payments - } - -getPaymentsByMonthByCategory : Time -> PaymentCategories -> Payments -> List ((Month, Int), List (CategoryId, Int)) -getPaymentsByMonthByCategory currentTime paymentCategories payments = - Payment.punctual payments - |> Payment.groupAndSortByMonth - |> List.map (\(m, payments) -> - ( m - , PaymentCategory.groupPaymentsByCategory paymentCategories payments - |> List.map (Tuple.mapSecond (List.sum << List.map .cost)) - ) - ) diff --git a/src/client/LoggedIn/Stat/Msg.elm b/src/client/LoggedIn/Stat/Msg.elm deleted file mode 100644 index d517544..0000000 --- a/src/client/LoggedIn/Stat/Msg.elm +++ /dev/null @@ -1,7 +0,0 @@ -module LoggedIn.Stat.Msg exposing - ( Msg(..) - ) - -type Msg = - NoOp - | UpdateChart diff --git a/src/client/LoggedIn/Stat/Update.elm b/src/client/LoggedIn/Stat/Update.elm deleted file mode 100644 index 2415733..0000000 --- a/src/client/LoggedIn/Stat/Update.elm +++ /dev/null @@ -1,24 +0,0 @@ -module LoggedIn.Stat.Update exposing - ( update - ) - -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat - -update : LoggedData -> Stat.Msg -> Stat.Model -> (Stat.Model, Cmd Stat.Msg) -update loggedData msg model = - case msg of - - Stat.NoOp -> - ( model - , Cmd.none - ) - - Stat.UpdateChart -> - let { currentTime, paymentCategories, payments } = loggedData - in ( { model - | paymentsByMonthByCategory = Stat.getPaymentsByMonthByCategory currentTime paymentCategories payments - } - , Cmd.none - ) diff --git a/src/client/LoggedIn/Stat/View.elm b/src/client/LoggedIn/Stat/View.elm deleted file mode 100644 index e389c67..0000000 --- a/src/client/LoggedIn/Stat/View.elm +++ /dev/null @@ -1,77 +0,0 @@ -module LoggedIn.Stat.View exposing - ( view - ) - -import Date exposing (Month) -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import List.Extra as List -import Time exposing (Time) - -import Chart.Api as Chart -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.View.Format as Format -import Model.Category exposing (CategoryId, Categories) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (Translations, getMessage, getParamMessage) -import Msg exposing (Msg) -import Utils.List as List -import View.Date as Date -import View.Plural exposing (plural) - -view : LoggedData -> Stat.Model -> Html Msg -view loggedData { paymentsByMonthByCategory } = - div - [ class "stat withMargin" ] - [ renderChart loggedData paymentsByMonthByCategory ] - -renderChart : LoggedData -> List ((Month, Int), List (CategoryId, Int)) -> Html msg -renderChart { currentTime, paymentCategories, categories, conf, translations } paymentsByMonthByCategory = - let monthPaymentMean = getMonthPaymentMean currentTime paymentsByMonthByCategory - title = getParamMessage [ Format.price conf monthPaymentMean ] translations "ByMonthsAndMean" - keys = - paymentsByMonthByCategory - |> List.map (\((month, year), _) -> Date.shortMonthAndYear month year translations) - series = - categories - |> Dict.toList - |> List.map (\(categoryId, category) -> - { values = - List.map - (\(_, paymentsByCategory) -> - paymentsByCategory - |> List.find (\(c, _) -> c == categoryId) - |> Maybe.map (toFloat << Tuple.second) - |> Maybe.withDefault 0 - ) - paymentsByMonthByCategory - , color = category.color - , label = category.name - } - ) - totalSerie = - { values = - List.transpose (List.map .values series) - |> List.map List.sum - , color = "black" - , label = getMessage translations "Total" - } - in Chart.from keys (series ++ [totalSerie]) - |> Chart.withSize { x = 2000, y = 900 } - |> Chart.withTitle title - |> Chart.withOrdinate 10 (Format.price conf << truncate) - |> Chart.toHtml - -getMonthPaymentMean : Time -> List ((Month, Int), List (CategoryId, Int)) -> Int -getMonthPaymentMean currentTime paymentsByMonthByCategory = - paymentsByMonthByCategory - |> List.filter (\((month, year), _) -> - let currentDate = Date.fromTime currentTime - in not (Date.month currentDate == month && Date.year currentDate == year) - ) - |> List.map (List.sum << List.map Tuple.second << Tuple.second) - |> List.mean diff --git a/src/client/LoggedIn/Update.elm b/src/client/LoggedIn/Update.elm deleted file mode 100644 index a1d5f7d..0000000 --- a/src/client/LoggedIn/Update.elm +++ /dev/null @@ -1,137 +0,0 @@ -module LoggedIn.Update exposing - ( update - ) - -import Date exposing (Date) -import Dict -import Form -import Http exposing (Error(..)) -import Platform.Cmd exposing (Cmd) -import String -import Task - -import LoggedData -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import LoggedIn.Home.Update as Home -import LoggedIn.Model as LoggedInModel -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Stat.Update as Stat -import Model exposing (Model) -import Model.Category exposing (Category) -import Model.Frequency exposing (Frequency(..)) -import Model.Income as Income exposing (Income) -import Model.Payment as Payment exposing (Payment) -import Model.PaymentCategory as PaymentCategory -import Server - -import Utils.Cmd exposing ((:>)) - -update : Model -> LoggedIn.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedIn.Msg) -update model msg loggedIn = - let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case msg of - - LoggedIn.NoOp -> - ( loggedIn - , Cmd.none - ) - - LoggedIn.HomeMsg homeMsg -> - case Home.update loggedData homeMsg loggedIn.home of - (home, effects) -> - ( { loggedIn | home = home } - , Cmd.map LoggedIn.HomeMsg effects - ) - - LoggedIn.StatMsg statMsg -> - case Stat.update loggedData statMsg loggedIn.stat of - (stat, effects) -> - ( { loggedIn | stat = stat } - , Cmd.map LoggedIn.StatMsg effects - ) - - LoggedIn.ValidateCreatePayment paymentId name cost date category frequency -> - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn - :> update model (LoggedIn.HomeMsg <| Home.UpdatePage 1) - :> (\loggedIn -> - let newPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn - | payments = newPayment :: loggedIn.payments - , paymentCategories = PaymentCategory.save name category loggedIn.paymentCategories - } - , Cmd.none - ) - ) - - LoggedIn.ValidateEditPayment paymentId name cost date category frequency -> - let updatedPayment = Payment paymentId name cost date loggedIn.me frequency - mbOldPayment = Payment.find paymentId loggedIn.payments - in ( { loggedIn - | payments = Payment.edit updatedPayment loggedIn.payments - , paymentCategories = - case mbOldPayment of - Just oldPayment -> - PaymentCategory.save name category loggedIn.paymentCategories - Nothing -> - loggedData.paymentCategories - } - , Cmd.none - ) - - LoggedIn.ValidateDeletePayment paymentId -> - let payments = Payment.delete paymentId loggedIn.payments - frequency = - case Form.getOutput loggedIn.home.search of - Just data -> data.frequency - Nothing -> Punctual - switchToPunctual = - ( frequency == Monthly - && List.isEmpty (Payment.monthly payments) - ) - in if switchToPunctual - then - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn - :> (\loggedIn -> - ( { loggedIn | payments = payments } - , Cmd.none - ) - ) - else - ( { loggedIn | payments = payments } - , Cmd.none - ) - - LoggedIn.ValidateCreateIncome incomeId amount date -> - let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date } - in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateEditIncome incomeId amount date -> - let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount - in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateDeleteIncome incomeId -> - ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateCreateCategory categoryId name color -> - let newCategory = { name = name, color = color } - in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories } - , Cmd.none - ) - - LoggedIn.ValidateEditCategory categoryId name color -> - let updateCategory _ = Just <| Category name color - in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none) - - LoggedIn.ValidateDeleteCategory categoryId -> - ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories } - , Cmd.none - ) diff --git a/src/client/LoggedIn/View.elm b/src/client/LoggedIn/View.elm deleted file mode 100644 index 4936c6e..0000000 --- a/src/client/LoggedIn/View.elm +++ /dev/null @@ -1,33 +0,0 @@ -module LoggedIn.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Page - -import Msg exposing (Msg) -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import LoggedData - -import LoggedIn.Model as LoggedInModel - -import LoggedIn.Home.View as Home -import LoggedIn.Income.View as Income -import LoggedIn.Category.View as Categories -import LoggedIn.Stat.View as Stat - -view : Model -> LoggedInModel.Model -> Html Msg -view model loggedIn = - div - [ class "loggedIn" ] - [ let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case model.page of - Page.Home -> Home.view loggedData loggedIn.home - Page.Income -> Income.view loggedData - Page.Categories -> Categories.view loggedData - Page.Statistics -> Stat.view loggedData loggedIn.stat - Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ] - ] diff --git a/src/client/LoggedIn/View/Format.elm b/src/client/LoggedIn/View/Format.elm deleted file mode 100644 index f41e2cd..0000000 --- a/src/client/LoggedIn/View/Format.elm +++ /dev/null @@ -1,37 +0,0 @@ -module LoggedIn.View.Format exposing - ( price - ) - -import String exposing (..) - -import Model.Conf exposing (Conf) - -price : Conf -> Int -> String -price conf amount = - ( number amount - ++ " " - ++ conf.currency - ) - -number : Int -> String -number n = - abs n - |> toString - |> toList - |> List.reverse - |> group 3 - |> List.intersperse [' '] - |> List.concat - |> List.reverse - |> fromList - |> append (if n < 0 then "-" else "") - -group : Int -> List a -> List (List a) -group n xs = - if List.length xs <= n - then - [xs] - else - let take = List.take n xs - drop = List.drop n xs - in take :: (group n drop) diff --git a/src/client/Main.elm b/src/client/Main.elm deleted file mode 100644 index 7981a1c..0000000 --- a/src/client/Main.elm +++ /dev/null @@ -1,26 +0,0 @@ -module Main exposing - ( main - ) - -import Navigation -import Time -import Msg exposing (Msg(UpdatePage)) - -import Model exposing (init) -import Update exposing (update) -import View exposing (view) -import Page -import Tooltip - -main = - Navigation.programWithFlags (UpdatePage << Page.fromLocation) - { init = init - , view = view - , update = update - , subscriptions = (\model -> - Sub.batch - [ Time.every 60000 Msg.UpdateTime - , Sub.map Msg.Tooltip Tooltip.subscription - ] - ) - } diff --git a/src/client/Model.elm b/src/client/Model.elm deleted file mode 100644 index 7f62416..0000000 --- a/src/client/Model.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Model exposing - ( Model - , init - ) - -import Time exposing (Time) -import Json.Decode as Decode - -import Navigation exposing (Location) - -import Html as Html - -import Page exposing (Page) -import Init as Init exposing (Init) -import Msg exposing (Msg) - -import Model.View exposing (..) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import LoggedIn.Model as LoggedInModel -import SignIn.Model as SignInModel - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -type alias Model = - { view : View - , currentTime : Time - , translations : Translations - , conf : Conf - , page : Page - , errors : List String - , dialog : Dialog.Model DialogModel.Model DialogMsg.Msg Msg - , tooltip : Tooltip.Model - } - -init : Decode.Value -> Location -> (Model, Cmd Msg) -init payload location = - let model = - case Decode.decodeValue Init.decoder payload of - Ok { time, translations, conf, result, windowSize } -> - { view = - case result of - InitEmpty -> - SignInView (SignInModel.init Nothing) - InitSuccess init -> - LoggedInView (LoggedInModel.init time init) - InitError error -> - SignInView (SignInModel.init (Just error)) - , currentTime = time - , translations = translations - , conf = conf - , page = Page.fromLocation location - , errors = [] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init windowSize.width windowSize.height - } - Err error -> - { view = SignInView (SignInModel.init (Just error)) - , currentTime = 0 - , translations = [] - , conf = { currency = "" } - , page = Page.fromLocation location - , errors = [ error ] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init 0 0 - } - in (model, Cmd.none) diff --git a/src/client/Model/Category.elm b/src/client/Model/Category.elm deleted file mode 100644 index 8b653a7..0000000 --- a/src/client/Model/Category.elm +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Category exposing - ( Categories - , Category - , CategoryId - , categoriesDecoder - , categoryIdDecoder - , empty - ) - -import Json.Decode as Decode exposing (Decoder) -import Utils.Json as Json -import Dict exposing (Dict) - -type alias Categories = Dict CategoryId Category - -type alias CategoryId = Int - -type alias Category = - { name : String - , color : String - } - -categoriesDecoder : Decoder Categories -categoriesDecoder = - Json.dictDecoder (Decode.field "id" categoryIdDecoder) <| - Decode.map2 - Category - (Decode.field "name" Decode.string) - (Decode.field "color" Decode.string) - -categoryIdDecoder : Decoder CategoryId -categoryIdDecoder = Decode.int - -empty : Categories -empty = Dict.empty diff --git a/src/client/Model/Conf.elm b/src/client/Model/Conf.elm deleted file mode 100644 index 308fa04..0000000 --- a/src/client/Model/Conf.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Model.Conf exposing - ( Conf - , confDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Conf = - { currency : String - } - -confDecoder : Decoder Conf -confDecoder = Decode.map Conf (Decode.field "currency" Decode.string) diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm deleted file mode 100644 index bfba02f..0000000 --- a/src/client/Model/Date.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Model.Date exposing - ( timeDecoder - , dateDecoder - ) - -import Date as Date exposing (Date) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import Time exposing (Time) - -timeDecoder : Decoder Time -timeDecoder = Decode.map Date.toTime dateDecoder - -dateDecoder : Decoder Date -dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult) diff --git a/src/client/Model/Frequency.elm b/src/client/Model/Frequency.elm deleted file mode 100644 index 40f9893..0000000 --- a/src/client/Model/Frequency.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Model.Frequency exposing - ( Frequency(..) - , decoder - , validate - , fromString - ) - -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode - -import Form.Validate as Validate exposing (Validation) - -type Frequency = Punctual | Monthly - -decoder : Decoder Frequency -decoder = - let frequencyResult input = - fromString input - |> Result.fromMaybe ("Could not deduce Punctual nor Monthly from " ++ input) - in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult) - -validate : Validation String Frequency -validate = - Validate.customValidation Validate.string (\str -> - fromString str - |> Result.fromMaybe (Validate.customError "InvalidFrequency") - ) - -fromString : String -> Maybe Frequency -fromString str = - if str == toString Punctual then - Just Punctual - else if str == toString Monthly then - Just Monthly - else - Nothing diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm deleted file mode 100644 index aa5f05f..0000000 --- a/src/client/Model/Income.elm +++ /dev/null @@ -1,101 +0,0 @@ -module Model.Income exposing - ( Incomes - , Income - , IncomeId - , incomesDecoder - , incomeIdDecoder - , incomeDefinedForAll - , userCumulativeIncomeSince - , cumulativeIncomesSince - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List exposing (..) -import Maybe.Extra as Maybe -import Time exposing (Time, hour) -import Utils.Json as Json - -import Model.Date exposing (timeDecoder) -import Model.User exposing (UserId, userIdDecoder) - -type alias Incomes = Dict IncomeId Income - -type alias IncomeId = Int - -type alias Income = - { userId : UserId - , time : Float - , amount : Int - } - -incomesDecoder : Decoder Incomes -incomesDecoder = - Json.dictDecoder (Decode.field "id" incomeIdDecoder) <| - Decode.map3 Income - (Decode.field "userId" userIdDecoder) - (Decode.field "date" timeDecoder) - (Decode.field "amount" Decode.int) - -incomeIdDecoder : Decoder IncomeId -incomeIdDecoder = Decode.int - -incomeDefinedForAll : List UserId -> Incomes -> Maybe Time -incomeDefinedForAll userIds incomes = - let userIncomes = List.map (\userId -> List.filter ((==) userId << .userId) << Dict.values <| incomes) userIds - firstIncomes = map (head << sortBy .time) userIncomes - in if all Maybe.isJust firstIncomes - then head << reverse << List.sort << map .time << Maybe.values <| firstIncomes - else Nothing - -userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int -userCumulativeIncomeSince currentTime since incomes userId = - incomes - |> Dict.values - |> List.filter (\income -> income.userId == userId) - |> cumulativeIncomesSince currentTime since - -cumulativeIncomesSince : Time -> Time -> (List Income) -> Int -cumulativeIncomesSince currentTime since incomes = - cumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince : Time -> List Income -> List Income -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> income.time >= time) incomes - in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt : Time -> List Income -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if x.time < time - then Just { userId = x.userId, time = time, amount = x.amount } - else Nothing - x1 :: x2 :: xs -> - if x1.time < time && x2.time >= time - then Just { userId = x1.userId, time = time, amount = x1.amount } - else getIncomeAt time (x2 :: xs) - [] -> - Nothing - -cumulativeIncome : Time -> List Income -> Int -cumulativeIncome currentTime incomes = - getIncomesWithDuration currentTime (List.sortBy .time incomes) - |> map durationIncome - |> sum - -getIncomesWithDuration : Time -> List Income -> List (Float, Int) -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(currentTime - income.time, income.amount)] - (income1 :: income2 :: xs) -> - (income2.time - income1.time, income1.amount) :: (getIncomesWithDuration currentTime (income2 :: xs)) - -durationIncome : (Float, Int) -> Int -durationIncome (duration, income) = - duration * toFloat income / (hour * 24 * 365 / 12) - |> truncate diff --git a/src/client/Model/Init.elm b/src/client/Model/Init.elm deleted file mode 100644 index db7069f..0000000 --- a/src/client/Model/Init.elm +++ /dev/null @@ -1,31 +0,0 @@ -module Model.Init exposing - ( Init - , initDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Payment exposing (Payments, paymentsDecoder) -import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder) -import Model.Income exposing (Incomes, incomesDecoder) -import Model.Category exposing (Categories, categoriesDecoder) -import Model.PaymentCategory exposing (PaymentCategories, paymentCategoriesDecoder) - -type alias Init = - { users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -initDecoder : Decoder Init -initDecoder = - Decode.map6 Init - (Decode.field "users" usersDecoder) - (Decode.field "me" userIdDecoder) - (Decode.field "payments" paymentsDecoder) - (Decode.field "incomes" incomesDecoder) - (Decode.field "categories" categoriesDecoder) - (Decode.field "paymentCategories" paymentCategoriesDecoder) diff --git a/src/client/Model/InitResult.elm b/src/client/Model/InitResult.elm deleted file mode 100644 index 7ce0be2..0000000 --- a/src/client/Model/InitResult.elm +++ /dev/null @@ -1,28 +0,0 @@ -module Model.InitResult exposing - ( InitResult(..) - , initResultDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Init exposing (Init, initDecoder) - -type InitResult = - InitEmpty - | InitSuccess Init - | InitError String - -initResultDecoder : Decoder InitResult -initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag - -initResultDecoderWithTag : String -> Decoder InitResult -initResultDecoderWithTag tag = - case tag of - "InitEmpty" -> - Decode.succeed InitEmpty - "InitSuccess" -> - Decode.map InitSuccess (Decode.field "contents" initDecoder) - "InitError" -> - Decode.map InitError (Decode.field "contents" Decode.string) - _ -> - Decode.fail <| "got " ++ tag ++ " for InitResult" diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm deleted file mode 100644 index 4d9190e..0000000 --- a/src/client/Model/Payer.elm +++ /dev/null @@ -1,137 +0,0 @@ -module Model.Payer exposing - ( Payers - , Payer - , ExceedingPayer - , getOrderedExceedingPayers - , useIncomesFrom - ) - -import Dict exposing (..) -import List -import Maybe -import Time exposing (Time) -import Date - -import Model.Payment exposing (Payments, totalPayments) -import Model.User exposing (Users, UserId, userIdDecoder) -import Model.Income exposing (..) - -import Utils.Dict exposing (mapValues) - -type alias Payers = Dict UserId Payer - -type alias Payer = - { preIncomePaymentSum : Int - , postIncomePaymentSum : Int - , incomes : List Income - } - -type alias PostPaymentPayer = - { preIncomePaymentSum : Int - , cumulativeIncome : Int - , ratio : Float - } - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer -getOrderedExceedingPayers currentTime users incomes payments = - let payers = getPayers currentTime users incomes payments - exceedingPayersOnPreIncome = - payers - |> mapValues .preIncomePaymentSum - |> Dict.toList - |> exceedingPayersFromAmounts - mbSince = useIncomesFrom users incomes payments - in case mbSince of - Just since -> - let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - postPaymentPayers - |> Dict.toList - |> List.map (.ratio << Tuple.second) - |> List.maximum - in case mbMaxRatio of - Just maxRatio -> - postPaymentPayers - |> mapValues (getFinalDiff maxRatio) - |> Dict.toList - |> exceedingPayersFromAmounts - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time -useIncomesFrom users incomes payments = - let firstPaymentTime = - payments - |> List.map (Date.toTime << .date) - |> List.sort - |> List.head - mbIncomeTime = incomeDefinedForAll (Dict.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just paymentTime, Just incomeTime) -> - Just (max paymentTime incomeTime) - _ -> - Nothing - -getPayers : Time -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Dict.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in userIds - |> List.map (\userId -> - ( userId - , { preIncomePaymentSum = - totalPayments - (\p -> (Date.toTime p.date) < (Maybe.withDefault currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> (Date.toTime p.date) >= t - ) - userId - payments - , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) - } - ) - ) - |> Dict.fromList - -exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer -exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts - in case mbMinAmount of - Nothing -> - [] - Just minAmount -> - userAmounts - |> List.map (\userAmount -> - { userId = Tuple.first userAmount - , amount = Tuple.second userAmount - minAmount - } - ) - |> List.filter (\payer -> payer.amount > 0) - -getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes - in { preIncomePaymentSum = payer.preIncomePaymentSum - , cumulativeIncome = cumulativeIncome - , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome - } - -getFinalDiff : Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome - |> truncate - in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm deleted file mode 100644 index 204f9f5..0000000 --- a/src/client/Model/Payment.elm +++ /dev/null @@ -1,117 +0,0 @@ -module Model.Payment exposing - ( perPage - , Payments - , Payment - , PaymentId - , paymentsDecoder - , paymentIdDecoder - , find - , edit - , delete - , totalPayments - , punctual - , monthly - , groupAndSortByMonth - , search - ) - -import Date exposing (..) -import Date.Extra.Core exposing (monthToInt, intToMonth) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import List -import List.Extra as List - -import Form.Validate as Validate exposing (Validation) -import Model.Date exposing (dateDecoder) -import Model.Frequency as Frequency exposing (Frequency(..)) -import Model.User exposing (UserId, userIdDecoder) -import Utils.List as List -import Utils.Search as Search - -perPage : Int -perPage = 7 - -type alias Payments = List Payment - -type alias Payment = - { id : PaymentId - , name : String - , cost : Int - , date : Date - , userId : UserId - , frequency : Frequency - } - -type alias PaymentId = Int - -paymentsDecoder : Decoder Payments -paymentsDecoder = Decode.list paymentDecoder - -paymentDecoder : Decoder Payment -paymentDecoder = - Decode.map6 Payment - (Decode.field "id" paymentIdDecoder) - (Decode.field "name" Decode.string) - (Decode.field "cost" Decode.int) - (Decode.field "date" dateDecoder) - (Decode.field "userId" userIdDecoder) - (Decode.field "frequency" Frequency.decoder) - -paymentIdDecoder : Decoder PaymentId -paymentIdDecoder = Decode.int - -find : PaymentId -> Payments -> Maybe Payment -find paymentId payments = - payments - |> List.find (\p -> p.id == paymentId) - -edit : Payment -> Payments -> Payments -edit payment payments = payment :: delete payment.id payments - -delete : PaymentId -> Payments -> Payments -delete paymentId = List.filter (((/=) paymentId) << .id) - -totalPayments : (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - payments - |> List.filter (\payment -> - paymentFilter payment - && payment.userId == userId - ) - |> List.map .cost - |> List.sum - -punctual : Payments -> Payments -punctual = List.filter ((==) Punctual << .frequency) - -monthly : Payments -> Payments -monthly = List.filter ((==) Monthly << .frequency) - -groupAndSortByMonth : Payments -> List ((Month, Int), Payments) -groupAndSortByMonth payments = - payments - |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date)) - |> List.sortBy Tuple.first - |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments)) - -search : String -> Frequency -> Payments -> Payments -search name frequency payments = - payments - |> List.filter ((==) frequency << .frequency) - |> paymentSort frequency - |> List.filter (searchSuccess name) - -paymentSort : Frequency -> Payments -> Payments -paymentSort frequency = - case frequency of - Punctual -> List.reverse << List.sortBy (Date.toTime << .date) - Monthly -> List.sortBy (String.toLower << .name) - -searchSuccess : String -> Payment -> Bool -searchSuccess search { name, cost } = - let searchSuccessWord word = - ( String.contains (Search.format word) (Search.format name) - || String.contains word (toString cost) - ) - in List.all searchSuccessWord (String.words search) diff --git a/src/client/Model/PaymentCategory.elm b/src/client/Model/PaymentCategory.elm deleted file mode 100644 index a4fceb1..0000000 --- a/src/client/Model/PaymentCategory.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Model.PaymentCategory exposing - ( PaymentCategories - , paymentCategoriesDecoder - , search - , groupPaymentsByCategory - , isCategoryUnused - , save - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List.Extra as List -import Maybe.Extra as Maybe - -import Model.Category exposing (CategoryId, categoryIdDecoder) -import Model.Payment exposing (Payments) -import Utils.Json as Json -import Utils.List as List -import Utils.Search as Search - -type alias PaymentCategories = List PaymentCategory - -type alias PaymentCategory = - { name : String - , category : CategoryId - } - -paymentCategoriesDecoder : Decoder PaymentCategories -paymentCategoriesDecoder = - Decode.list <| Decode.map2 PaymentCategory - (Decode.field "name" Decode.string) - (Decode.field "category" categoryIdDecoder) - -groupPaymentsByCategory : PaymentCategories -> Payments -> List (CategoryId, Payments) -groupPaymentsByCategory paymentCategories payments = - payments - |> List.groupBy (\payment -> - search payment.name paymentCategories - |> Maybe.withDefault -1 - ) - |> List.filterMap (\(category, payments) -> - case category of - -1 -> Nothing - _ -> Just (category, payments) - ) - -search : String -> PaymentCategories -> Maybe CategoryId -search paymentName paymentCategories = - paymentCategories - |> List.find (\pc -> Search.format pc.name == Search.format paymentName) - |> Maybe.map .category - -isCategoryUnused : CategoryId -> PaymentCategories -> Bool -isCategoryUnused category paymentCategories = - paymentCategories - |> List.find ((==) category << .category) - |> Maybe.isNothing - -save : String -> CategoryId -> PaymentCategories -> PaymentCategories -save name category paymentCategories = - { name = name, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format name) paymentCategories diff --git a/src/client/Model/Size.elm b/src/client/Model/Size.elm deleted file mode 100644 index f40fb01..0000000 --- a/src/client/Model/Size.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Model.Size exposing - ( Size - , sizeDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Size = - { width: Int - , height: Int - } - -sizeDecoder : Decoder Size -sizeDecoder = - Decode.map2 Size - (Decode.field "width" Decode.int) - (Decode.field "height" Decode.int) diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm deleted file mode 100644 index 9b314e1..0000000 --- a/src/client/Model/Translations.elm +++ /dev/null @@ -1,68 +0,0 @@ -module Model.Translations exposing - ( translationsDecoder - , Translations - , Translation - , getMessage - , getParamMessage - ) - -import Maybe exposing (withDefault) -import Json.Decode as Decode exposing (Decoder) -import String - -type alias Translations = List Translation - -translationsDecoder : Decoder Translations -translationsDecoder = Decode.list translationDecoder - -type alias Translation = - { key : String - , message : List MessagePart - } - -getTranslation : String -> Translations -> Maybe (List MessagePart) -getTranslation key translations = - translations - |> List.filter (\translation -> String.toLower translation.key == String.toLower key) - |> List.head - |> Maybe.map .message - -translationDecoder : Decoder Translation -translationDecoder = - Decode.map2 Translation - (Decode.field "key" Decode.string) - (Decode.field "message" (Decode.list partDecoder)) - -type MessagePart = - Order Int - | Str String - -partDecoder : Decoder MessagePart -partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag - -partDecoderWithTag : String -> Decoder MessagePart -partDecoderWithTag tag = - case tag of - "Order" -> Decode.map Order (Decode.field "contents" Decode.int) - _ -> Decode.map Str (Decode.field "contents" Decode.string) - ------ - -getMessage : Translations -> String -> String -getMessage = getParamMessage [] - -getParamMessage : List String -> Translations -> String -> String -getParamMessage values translations key = - getTranslation key translations - |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts)) - |> withDefault key - -replacePart : List String -> MessagePart -> String -replacePart values part = - case part of - Str str -> str - Order n -> - values - |> List.drop (n - 1) - |> List.head - |> withDefault ("{" ++ (toString n) ++ "}") diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm deleted file mode 100644 index f6e8147..0000000 --- a/src/client/Model/User.elm +++ /dev/null @@ -1,44 +0,0 @@ -module Model.User exposing - ( Users - , usersDecoder - , User - , userDecoder - , UserId - , userIdDecoder - , getUserName - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -type alias Users = Dict UserId User - -type alias UserId = Int - -type alias User = - { name : String - , email : String - } - -usersDecoder : Decoder Users -usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder) - -userWithIdDecoder : Decode.Decoder (UserId, User) -userWithIdDecoder = - Decode.map2 (,) - (Decode.field "id" userIdDecoder) - userDecoder - -userIdDecoder : Decoder UserId -userIdDecoder = Decode.int - -userDecoder : Decoder User -userDecoder = - Decode.map2 User - (Decode.field "name" Decode.string) - (Decode.field "email" Decode.string) - -getUserName : Users -> UserId -> Maybe String -getUserName users userId = - Dict.get userId users - |> Maybe.map .name diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm deleted file mode 100644 index 61d42a7..0000000 --- a/src/client/Model/View.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Model.View exposing - ( View(..) - ) - -import Model.Payment exposing (Payments) - -import SignIn.Model as SignInModel -import LoggedIn.Model as LoggedInModel - -type View = - SignInView SignInModel.Model - | LoggedInView LoggedInModel.Model diff --git a/src/client/Msg.elm b/src/client/Msg.elm deleted file mode 100644 index 5970747..0000000 --- a/src/client/Msg.elm +++ /dev/null @@ -1,49 +0,0 @@ -module Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) -import Time exposing (Time) - -import Page exposing (Page) - -import Model.Init exposing (Init) -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Category exposing (CategoryId) - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -import SignIn.Msg as SignInMsg -import LoggedIn.Msg as LoggedInMsg - -type Msg = - NoOp - | UpdatePage Page - | SignIn String - | UpdateTime Time - | GoLoggedInView Init - | UpdateSignIn SignInMsg.Msg - | UpdateLoggedIn LoggedInMsg.Msg - | GoSignInView - | SignOut - | Error String - | Dialog (Dialog.Msg DialogModel.Model DialogMsg.Msg Msg) - | Tooltip Tooltip.Msg - - | CreatePayment String Int Date CategoryId Frequency - | EditPayment PaymentId String Int Date CategoryId Frequency - | DeletePayment PaymentId - - | CreateIncome Int Date - | EditIncome IncomeId Int Date - | DeleteIncome IncomeId - - | CreateCategory String String - | EditCategory CategoryId String String - | DeleteCategory CategoryId diff --git a/src/client/Page.elm b/src/client/Page.elm deleted file mode 100644 index 39232e0..0000000 --- a/src/client/Page.elm +++ /dev/null @@ -1,43 +0,0 @@ -module Page exposing - ( Page(..) - , toHash - , fromLocation - ) - -import Navigation exposing (Location) -import UrlParser exposing (Parser, (</>), s) -import String - -type Page = - Home - | Income - | Categories - | Statistics - | NotFound - -toHash : Page -> String -toHash page = - case page of - Home -> "#" - Income -> "#income" - Categories -> "#categories" - Statistics -> "#statistics" - NotFound -> "#notFound" - -fromLocation : Location -> Page -fromLocation location = - if location.hash == "" - then - Home - else - case UrlParser.parseHash pageParser location of - Just page -> page - Nothing -> NotFound - -pageParser : Parser (Page -> a) a -pageParser = - UrlParser.oneOf - [ UrlParser.map Income (s "income") - , UrlParser.map Categories (s "categories") - , UrlParser.map Statistics (s "statistics") - ] diff --git a/src/client/Server.elm b/src/client/Server.elm deleted file mode 100644 index c44b777..0000000 --- a/src/client/Server.elm +++ /dev/null @@ -1,115 +0,0 @@ -module Server exposing - ( signIn - , createPayment - , editPayment - , deletePayment - , createIncome - , editIncome - , deleteIncome - , createCategory - , editCategory - , deleteCategory - , signOut - ) - -import Task as Task exposing (Task) -import Http exposing (Error) -import Date -import Json.Decode as Decode -import Json.Encode as Encode -import Date exposing (Date) - -import Date.Extra.Format as DateFormat - -import Utils.Http as HttpUtils - -import Model.Payment exposing (..) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (incomeIdDecoder, IncomeId) -import Model.Category exposing (categoryIdDecoder, CategoryId) -import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) -import Model.Init exposing (Init) - -signIn : String -> (Result Error String -> msg) -> Cmd msg -signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString - -createPayment : String -> Int -> Date -> CategoryId -> Frequency -> (Result Error PaymentId -> msg) -> Cmd msg -createPayment name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - expect = Http.expectJson (Decode.field "id" paymentIdDecoder) - in HttpUtils.jsonRequest "POST" "/payment" expect handleResult json - -editPayment : PaymentId -> String -> Int -> Date -> CategoryId -> Frequency -> (Result Error String -> msg) -> Cmd msg -editPayment paymentId name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("id", Encode.int paymentId) - , ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - in HttpUtils.jsonRequest "PUT" "/payment" Http.expectString handleResult json - -deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg -deletePayment paymentId = - HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString - -createIncome : Int -> Date -> (Result Error IncomeId -> msg) -> Cmd msg -createIncome amount date handleResult = - let json = - Encode.object - [ ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - expect = Http.expectJson (Decode.field "id" incomeIdDecoder) - in HttpUtils.jsonRequest "POST" "/income" expect handleResult json - -editIncome : IncomeId -> Int -> Date -> (Result Error String -> msg) -> Cmd msg -editIncome incomeId amount date handleResult = - let json = - Encode.object - [ ("id", Encode.int incomeId) - , ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - in HttpUtils.jsonRequest "PUT" "/income" Http.expectString handleResult json - -deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg -deleteIncome incomeId = - HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString - -createCategory : String -> String -> (Result Error CategoryId -> msg) -> Cmd msg -createCategory name color handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("color", Encode.string color) - ] - expect = Http.expectJson (Decode.field "id" categoryIdDecoder) - in HttpUtils.jsonRequest "POST" "/category" expect handleResult json - -editCategory : CategoryId -> String -> String -> (Result Error String -> msg) -> Cmd msg -editCategory categoryId name color handleResult = - let json = - Encode.object - [ ("id", Encode.int categoryId) - , ("name", Encode.string name) - , ("color", Encode.string color) - ] - in HttpUtils.jsonRequest "PUT" "/category" Http.expectString handleResult json - -deleteCategory : CategoryId -> (Result Error String -> msg) -> Cmd msg -deleteCategory categoryId = - HttpUtils.request "DELETE" ("/category?id=" ++ (toString categoryId)) Http.expectString - -signOut : (Result Error String -> msg) -> Cmd msg -signOut = HttpUtils.request "POST" "/signOut" Http.expectString diff --git a/src/client/SignIn/Model.elm b/src/client/SignIn/Model.elm deleted file mode 100644 index 19d4305..0000000 --- a/src/client/SignIn/Model.elm +++ /dev/null @@ -1,17 +0,0 @@ -module SignIn.Model exposing - ( Model - , init - ) - -type alias Model = - { login : String - , waitingServer : Bool - , result : Maybe (Result String String) - } - -init : Maybe String -> Model -init mbSignInError = - { login = "" - , waitingServer = False - , result = Maybe.map Err mbSignInError - } diff --git a/src/client/SignIn/Msg.elm b/src/client/SignIn/Msg.elm deleted file mode 100644 index f753ebd..0000000 --- a/src/client/SignIn/Msg.elm +++ /dev/null @@ -1,9 +0,0 @@ -module SignIn.Msg exposing - ( Msg(..) - ) - -type Msg = - UpdateLogin String - | WaitingServer - | ValidLogin - | ErrorLogin String diff --git a/src/client/SignIn/Update.elm b/src/client/SignIn/Update.elm deleted file mode 100644 index 98de777..0000000 --- a/src/client/SignIn/Update.elm +++ /dev/null @@ -1,31 +0,0 @@ -module SignIn.Update exposing - ( update - ) - -import SignIn.Model exposing (..) -import SignIn.Msg exposing (..) - -import Model.Translations exposing (getMessage, Translations) - -update : Translations -> Msg -> Model -> Model -update translations msg signInView = - case msg of - UpdateLogin login -> - { signInView | - login = login - } - WaitingServer -> - { signInView - | waitingServer = True - } - ValidLogin -> - { signInView - | login = "" - , result = Just (Ok (getMessage translations "SignInEmailSent")) - , waitingServer = False - } - ErrorLogin message -> - { signInView - | result = Just (Err message) - , waitingServer = False - } diff --git a/src/client/SignIn/View.elm b/src/client/SignIn/View.elm deleted file mode 100644 index 88f74b0..0000000 --- a/src/client/SignIn/View.elm +++ /dev/null @@ -1,63 +0,0 @@ -module SignIn.View exposing - ( view - ) - -import Json.Decode as Decode - -import FontAwesome -import View.Color as Color - -import Html as H exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import SignIn.Msg as SignInMsg -import SignIn.Model as SignInModel - -import Update exposing (..) - -import Model exposing (Model) -import Msg exposing (..) -import Model.Translations exposing (getMessage) - -import View.Events exposing (onSubmitPrevDefault) - -view : Model -> SignInModel.Model -> Html Msg -view model signInModel = - div - [ class "signIn" ] - [ H.form - [ onSubmitPrevDefault (SignIn signInModel.login) ] - [ input - [ value signInModel.login - , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) - , name "email" - ] - [] - , button - [] - [ if signInModel.waitingServer - then FontAwesome.spinner Color.white 20 - else text (getMessage model.translations "SignIn") - ] - ] - , div - [ class "result" ] - [ signInResult model signInModel ] - ] - -signInResult : Model -> SignInModel.Model -> Html Msg -signInResult model signInModel = - case signInModel.result of - Just result -> - case result of - Ok login -> - div - [ class "success" ] - [ text (getMessage model.translations "SignInEmailSent") ] - Err error -> - div - [ class "error" ] - [ text (getMessage model.translations error) ] - Nothing -> - text "" diff --git a/src/client/Tooltip.elm b/src/client/Tooltip.elm deleted file mode 100644 index 4f70cda..0000000 --- a/src/client/Tooltip.elm +++ /dev/null @@ -1,113 +0,0 @@ -module Tooltip exposing - ( Msg(..) - , Model - , init - , subscription - , update - , view - , show - ) - -import Platform.Cmd - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Mouse exposing (Position) -import Window exposing (Size) - -type Msg = - UpdateMousePosition Position - | UpdateWindowSize Size - | ShowMessage String - | HideMessage - -type alias Model = - { mousePosition : Maybe Position - , windowSize : Size - , message : Maybe String - } - -init : Int -> Int -> Model -init width height = - { mousePosition = Nothing - , windowSize = - { width = width - , height = height - } - , message = Nothing - } - -subscription : Sub Msg -subscription = - Sub.batch - [ Mouse.moves UpdateMousePosition - , Window.resizes UpdateWindowSize - ] - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - UpdateMousePosition position -> - ( { model | mousePosition = Just position } - , Cmd.none - ) - - UpdateWindowSize size -> - ( { model | windowSize = size } - , Cmd.none - ) - - ShowMessage message -> - ( { model | message = Just message } - , Cmd.none - ) - - HideMessage -> - ( { model | message = Nothing } - , Cmd.none - ) - -view : Model -> Html Msg -view { mousePosition, windowSize, message } = - case (mousePosition, message) of - (Just pos, Just msg) -> - div - [ class "tooltip" - , style - [ ("position", "absolute") - , horizontalPosition windowSize pos - , ("top", px <| pos.y + 15) - ] - ] - [ text msg ] - _ -> - text "" - -horizontalPosition : Size -> Position -> (String, String) -horizontalPosition size position = - if isLeft size position - then ("left", px <| position.x + 5) - else ("right", px <| size.width - position.x) - -verticalPosition : Size -> Position -> (String, String) -verticalPosition size position = - if isTop size position - then ("top", px <| position.y + 20) - else ("bottom", px <| size.height - position.y + 15) - -px : Int -> String -px n = (toString n) ++ "px" - -isLeft : Size -> Position -> Bool -isLeft { width } { x } = x < width // 2 - -isTop : Size -> Position -> Bool -isTop { height } { y } = y < height // 2 - -show : (Msg -> msg) -> String -> List (Attribute msg) -show mapMsg message = - [ onMouseEnter <| mapMsg <| ShowMessage message - , onMouseLeave <| mapMsg <| HideMessage - ] diff --git a/src/client/Update.elm b/src/client/Update.elm deleted file mode 100644 index 4284b65..0000000 --- a/src/client/Update.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Update exposing - ( update - ) - -import Navigation exposing (Location) -import Platform.Cmd exposing (Cmd) -import Task - -import Dialog -import Dialog.Update as DialogUpdate -import LoggedIn.Model as LoggedIn -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Update as LoggedIn -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Model.View as V -import Msg exposing (..) -import Page exposing (Page(..)) -import Server -import SignIn.Model as SignInModel -import SignIn.Msg as SignInMsg -import SignIn.Update as SignInUpdate -import Tooltip -import Utils.Cmd exposing ((:>)) -import Utils.Http exposing (errorKey) - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - - NoOp -> - (model, Cmd.none) - - UpdatePage page -> - ( { model | page = page } - , if page == Statistics - then - let msg = UpdateLoggedIn <| LoggedIn.StatMsg <| Stat.UpdateChart - in Task.perform (\_ -> msg) (Task.succeed ()) - else - Cmd.none - ) - - SignIn email -> - ( applySignIn model (SignInMsg.WaitingServer) - , Server.signIn email (\result -> case result of - Ok _ -> UpdateSignIn SignInMsg.ValidLogin - Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error)) - ) - ) - - GoLoggedInView init -> - ( { model | view = V.LoggedInView (LoggedIn.init model.currentTime init) } - , Cmd.none - ) - - UpdateTime time -> - ({ model | currentTime = time }, Cmd.none) - - GoSignInView -> - ({ model | view = V.SignInView (SignInModel.init Nothing) }, Cmd.none) - - UpdateSignIn signInMsg -> - (applySignIn model signInMsg, Cmd.none) - - UpdateLoggedIn loggedInMsg -> - applyLoggedIn model loggedInMsg - - SignOut -> - ( model - , Server.signOut (\result -> case result of - Ok _ -> GoSignInView - Err _ -> Error "SignOutError" - ) - ) - - Error error -> - ({ model | errors = model.errors ++ [ error ] }, Cmd.none) - - Dialog dialogMsg -> - Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog - |> Tuple.mapFirst (\dialog -> { model | dialog = dialog }) - :> update (Tooltip Tooltip.HideMessage) - - Tooltip tooltipMsg -> - let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip - in ( { model | tooltip = newTooltip } - , Cmd.map Tooltip command - ) - - CreatePayment name cost date category frequency -> - ( model - , Server.createPayment name cost date category frequency (\result -> case result of - Ok paymentId -> UpdateLoggedIn <| LoggedIn.ValidateCreatePayment paymentId name cost date category frequency - Err _ -> Error "CreatePaymentError" - ) - ) - - EditPayment paymentId name cost date category frequency -> - ( model - , Server.editPayment paymentId name cost date category frequency (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditPayment paymentId name cost date category frequency - Err _ -> Error "EditPaymentError" - ) - ) - - DeletePayment paymentId -> - ( model - , Server.deletePayment paymentId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeletePayment paymentId - Err _ -> Error "DeletePaymentError" - ) - ) - - CreateIncome amount date -> - ( model - , Server.createIncome amount date (\result -> case result of - Ok incomeId -> UpdateLoggedIn <| LoggedIn.ValidateCreateIncome incomeId amount date - Err _ -> Error "CreateIncomeError" - ) - ) - - EditIncome incomeId amount date -> - ( model - , Server.editIncome incomeId amount date (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditIncome incomeId amount date - Err _ -> Error "EditIncomeError" - ) - ) - - DeleteIncome incomeId -> - ( model - , Server.deleteIncome incomeId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteIncome incomeId - Err _ -> Error "DeleteIncomeError" - ) - ) - - CreateCategory name color -> - ( model - , Server.createCategory name color (\result -> case result of - Ok categoryId -> UpdateLoggedIn <| LoggedIn.ValidateCreateCategory categoryId name color - Err _ -> Error "CreateCategoryError" - ) - ) - - EditCategory categoryId name color -> - ( model - , Server.editCategory categoryId name color (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditCategory categoryId name color - Err _ -> Error "EditCategoryError" - ) - ) - - DeleteCategory categoryId -> - ( model - , Server.deleteCategory categoryId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteCategory categoryId - Err _ -> Error "DeleteCategoryError" - ) - ) - - -applySignIn : Model -> SignInMsg.Msg -> Model -applySignIn model signInMsg = - case model.view of - V.SignInView signInView -> - { model | view = V.SignInView (SignInUpdate.update model.translations signInMsg signInView) } - _ -> - model - -applyLoggedIn : Model -> LoggedIn.Msg -> (Model, Cmd Msg) -applyLoggedIn model loggedInMsg = - case model.view of - V.LoggedInView loggedInView -> - let (view, cmd) = LoggedIn.update model loggedInMsg loggedInView - in ( { model | view = V.LoggedInView view } - , Cmd.map UpdateLoggedIn cmd - ) - _ -> - (model, Cmd.none) diff --git a/src/client/Utils/Cmd.elm b/src/client/Utils/Cmd.elm deleted file mode 100644 index 5f41cbe..0000000 --- a/src/client/Utils/Cmd.elm +++ /dev/null @@ -1,16 +0,0 @@ -module Utils.Cmd exposing - ( pipeUpdate - , (:>) - ) - -import Platform.Cmd as Cmd - -pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg) -pipeUpdate (model, cmd) f = - let (newModel, newCmd) = f model - in (newModel, Cmd.batch [ cmd, newCmd ]) - -(:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a) -(:>) = pipeUpdate - -infixl 0 :> diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm deleted file mode 100644 index 7d708e2..0000000 --- a/src/client/Utils/Dict.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Dict exposing - ( mapValues - ) - -import Dict as Dict exposing (..) - -mapValues : (a -> b) -> Dict comparable a -> Dict comparable b -mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList - -onSecond : (a -> b) -> (comparable, a) -> (comparable, b) -onSecond f tuple = case tuple of (x, y) -> (x, f y) diff --git a/src/client/Utils/Either.elm b/src/client/Utils/Either.elm deleted file mode 100644 index 275fc8c..0000000 --- a/src/client/Utils/Either.elm +++ /dev/null @@ -1,9 +0,0 @@ -module Utils.Either exposing - ( toMaybeError - ) - -toMaybeError : Result a b -> Maybe a -toMaybeError result = - case result of - Ok _ -> Nothing - Err x -> Just x diff --git a/src/client/Utils/Form.elm b/src/client/Utils/Form.elm deleted file mode 100644 index 6793222..0000000 --- a/src/client/Utils/Form.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Form exposing - ( fieldAsText - ) - -import Form exposing (Form) - -fieldAsText : Form a b -> String -> String -fieldAsText form field = - Form.getFieldAsString field form - |> .value - |> Maybe.withDefault "" diff --git a/src/client/Utils/Http.elm b/src/client/Utils/Http.elm deleted file mode 100644 index dd3870a..0000000 --- a/src/client/Utils/Http.elm +++ /dev/null @@ -1,39 +0,0 @@ -module Utils.Http exposing - ( jsonRequest - , request - , errorKey - ) - -import Http exposing (..) -import Task exposing (..) -import Json.Decode as Decode exposing (Decoder, Value) -import Json.Encode as Encode - -jsonRequest : String -> String -> Expect a -> (Result Error a -> msg) -> Encode.Value -> Cmd msg -jsonRequest method url expect handleResult value = - requestWithBody method url (jsonBody value) expect handleResult - -request : String -> String -> Expect a -> (Result Error a -> msg) -> Cmd msg -request method url = requestWithBody method url emptyBody - -requestWithBody : String -> String -> Body -> Expect a -> (Result Error a -> msg) -> Cmd msg -requestWithBody method url body expect handleResult = - let req = Http.request - { method = method - , headers = [] - , url = url - , body = body - , expect = expect - , timeout = Nothing - , withCredentials = False - } - in send handleResult req - -errorKey : Error -> String -errorKey error = - case error of - BadUrl _ -> "BadUrl" - Timeout -> "Timeout" - NetworkError -> "NetworkError" - BadPayload _ _ -> "BadPayload" - BadStatus response -> response.body diff --git a/src/client/Utils/Json.elm b/src/client/Utils/Json.elm deleted file mode 100644 index 29e815b..0000000 --- a/src/client/Utils/Json.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Utils.Json exposing - ( dictDecoder - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -dictDecoder : Decoder comparable -> Decoder a -> Decoder (Dict comparable a) -dictDecoder keyDecoder valueDecoder = - Decode.map2 (,) keyDecoder valueDecoder - |> Decode.list - |> Decode.map Dict.fromList diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm deleted file mode 100644 index 8e26e85..0000000 --- a/src/client/Utils/List.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Utils.List exposing - ( groupBy - , mean - , links - ) - -import Dict -import Maybe.Extra as Maybe - -groupBy : (a -> comparable) -> List a -> List (comparable, List a) -groupBy f xs = - let addItem item dict = - let groupItems = Dict.get (f item) dict |> Maybe.withDefault [] - in Dict.insert (f item) (item :: groupItems) dict - in List.foldr addItem Dict.empty xs - |> Dict.toList - -mean : List Int -> Int -mean xs = (List.sum xs) // (List.length xs) - -links : List a -> List (a, a) -links xs = - let reversed = List.reverse xs - in List.foldr - (\x acc -> - case Maybe.map Tuple.first (List.head acc) of - Just y -> - (x, y) :: acc - _ -> - acc - ) - (case reversed of - x :: y :: _ -> [(y, x)] - _ -> [] - ) - (List.reverse << List.drop 2 <| reversed) diff --git a/src/client/Utils/Search.elm b/src/client/Utils/Search.elm deleted file mode 100644 index 1b70387..0000000 --- a/src/client/Utils/Search.elm +++ /dev/null @@ -1,10 +0,0 @@ -module Utils.Search exposing - ( format - ) - -import String - -import Utils.String as String - -format : String -> String -format = String.unaccent << String.toLower diff --git a/src/client/Utils/String.elm b/src/client/Utils/String.elm deleted file mode 100644 index 90fe68e..0000000 --- a/src/client/Utils/String.elm +++ /dev/null @@ -1,38 +0,0 @@ -module Utils.String exposing - ( unaccent - ) - -unaccent : String -> String -unaccent = String.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/client/Validation.elm b/src/client/Validation.elm deleted file mode 100644 index de27963..0000000 --- a/src/client/Validation.elm +++ /dev/null @@ -1,65 +0,0 @@ -module Validation exposing - ( cost - , date - , category - , color - , new - ) - -import Date exposing (Date) -import Date.Extra.Core exposing (intToMonth) -import Date.Extra.Create exposing (dateFromFields) -import Dict -import Regex -import String exposing (toInt, split) - -import Form.Validate as Validate exposing (Validation) -import Form.Error as Error exposing (ErrorValue(CustomError)) - -import Model.Category exposing (Categories, CategoryId) - -cost : Validation String Int -cost = - Validate.customValidation Validate.int (\n -> - if n == 0 - then Err (Validate.customError "CostMustNotBeNull") - else Ok n - ) - -date : Validation String Date -date = - Validate.customValidation Validate.string (\str -> - case split "/" str of - [day, month, year] -> - case (toInt day, toInt month, toInt year) of - (Ok dayNum, Ok monthNum, Ok yearNum) -> - Ok (dateFromFields yearNum (intToMonth monthNum) dayNum 0 0 0 0) - _ -> Err (Validate.customError "InvalidDate") - _ -> Err (Validate.customError "InvalidDate") - ) - -category : Categories -> Validation String CategoryId -category categories = - Validate.customValidation Validate.string (\str -> - case toInt str of - Ok category -> - if List.member category (Dict.keys categories) - then Ok category - else Err (Validate.customError "InvalidCategory") - Err _ -> - Err (Validate.customError "InvalidCategory") - ) - -color : Validation String String -color = - Validate.customValidation Validate.string (\str -> - if Regex.contains (Regex.regex "^#[0-9a-fA-F]{6}$") str - then Ok str - else Err (Validate.customError "InvalidColor") - ) - -new : List x -> x -> Validation String x -new xs x field = - if List.member x xs - then Err (Error.value <| CustomError "AlreadyExists") - else Ok x diff --git a/src/client/View.elm b/src/client/View.elm deleted file mode 100644 index deee272..0000000 --- a/src/client/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Model exposing (Model) -import Msg exposing (Msg) -import Model.View exposing (..) -import LoggedData -import Dialog -import Tooltip - -import View.Header as Header -import View.Errors as Errors - -import SignIn.View as SignInView -import LoggedIn.View as LoggedInView - -view : Model -> Html Msg -view model = - div - [] - [ Header.view model - , case model.view of - SignInView signIn -> - SignInView.view model signIn - LoggedInView loggedIn -> - LoggedInView.view model loggedIn - , Errors.view model.translations model.errors - , Dialog.view model.dialog - , Html.map Msg.Tooltip <| Tooltip.view model.tooltip - ] diff --git a/src/client/View/Color.elm b/src/client/View/Color.elm deleted file mode 100644 index a2a20c7..0000000 --- a/src/client/View/Color.elm +++ /dev/null @@ -1,12 +0,0 @@ -module View.Color exposing (..) - -import Color exposing (Color) - -chestnutRose : Color -chestnutRose = Color.rgb 207 92 86 - -white : Color -white = Color.white - -silver : Color -silver = Color.rgb 200 200 200 diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 6df971b..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,57 +0,0 @@ -module View.Date exposing - ( shortMonthAndYear - , shortView - , longView - , monthView - ) - -import Date exposing (..) -import Date.Extra.Core as Date -import String - -import Model.Translations exposing (..) - -shortMonthAndYear : Month -> Int -> Translations -> String -shortMonthAndYear month year translations = - let params = - [ String.pad 2 '0' (toString (Date.monthToInt month)) - , toString year - ] - in getParamMessage params translations "ShortMonthAndYear" - -shortView : Date -> Translations -> String -shortView date translations = - let params = - [ String.pad 2 '0' (toString (Date.day date)) - , String.pad 2 '0' (toString (Date.monthToInt (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "ShortDate" - -longView : Date -> Translations -> String -longView date translations = - let params = - [ toString (Date.day date) - , (getMessage translations (getMonthKey (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "LongDate" - -monthView : Translations -> Month -> String -monthView translations month = getMessage translations (getMonthKey month) - -getMonthKey : Month -> String -getMonthKey month = - case month of - Jan -> "January" - Feb -> "February" - Mar -> "March" - Apr -> "April" - May -> "May" - Jun -> "June" - Jul -> "July" - Aug -> "August" - Sep -> "September" - Oct -> "October" - Nov -> "November" - Dec -> "December" diff --git a/src/client/View/Errors.elm b/src/client/View/Errors.elm deleted file mode 100644 index 3e25c99..0000000 --- a/src/client/View/Errors.elm +++ /dev/null @@ -1,21 +0,0 @@ -module View.Errors exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model.Translations exposing (Translations, getMessage) - -view : Translations -> List String -> Html msg -view translations errors = - ul - [ class "errors" ] - ( List.map (errorView translations) errors) - -errorView : Translations -> String -> Html msg -errorView translations error = - li - [ class "error" ] - [ text <| getMessage translations error ] diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index d71d67d..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,15 +0,0 @@ -module View.Events exposing - ( onSubmitPrevDefault - ) - -import Json.Decode as Decode -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -onSubmitPrevDefault : msg -> Attribute msg -onSubmitPrevDefault value = - onWithOptions - "submit" - { defaultOptions | preventDefault = True } - (Decode.succeed value) diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm deleted file mode 100644 index 977ca0a..0000000 --- a/src/client/View/Form.elm +++ /dev/null @@ -1,152 +0,0 @@ -module View.Form exposing - ( textInput - , colorInput - , selectInput - , radioInputs - , hiddenSubmit - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Maybe.Extra as Maybe - -import FontAwesome -import View.Color as Color - -import Form exposing (Form, FieldState) -import Form.Input as Input -import Form.Error as FormError exposing (ErrorValue(..)) -import Form.Field as Field - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Translations as Translations exposing (Translations) - -textInput : Translations -> Form String a -> String -> String -> Html Form.Msg -textInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - fieldId = formName ++ fieldName - in div - [ classList - [ ("textInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ Input.textInput - field - [ id fieldId - , classList [ ("filled", Maybe.isJust field.value) ] - , value (Maybe.withDefault "" field.value) - ] - , label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , button - [ type_ "button" - , onClick (Form.Input fieldName Form.Text Field.EmptyField) - , tabindex -1 - ] - [ FontAwesome.times Color.silver 15 ] - , formError translations field - ] - -colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg -colorInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - in div - [ classList - [ ("colorInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] - , Input.textInput - field - [ id (formName ++ fieldName) - , type_ "color" - ] - ] - -radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg -radioInputs translations form formName radioName fieldNames = - let field = Form.getFieldAsString radioName form - in div - [ classList - [ ("radioGroup", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ div - [ class "title" ] - [ text (Translations.getMessage translations (formName ++ radioName) ) ] - , div - [ class "radioInputs" ] - (List.map (radioInput translations field formName) fieldNames) - , formError translations field - ] - -radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg -radioInput translations field formName fieldName = - div - [ class "radioInput" ] - [ Input.radioInput - field.path - field - [ id (formName ++ fieldName) - , value fieldName - , checked (field.value == Just fieldName) - ] - , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) - ] - ] - -selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg -selectInput translations form formName selectName options = - let field = Form.getFieldAsString selectName form - fieldId = formName ++ selectName - in div - [ classList - [ ("selectInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , Input.selectInput - (("", "") :: options) - field - [ id fieldId ] - , formError translations field - ] - -formError : Translations -> FieldState String a -> Html msg -formError translations field = - case field.liveError of - Just error -> - let errorElement error params = - div - [ class "errorMessage" ] - [ text (Translations.getParamMessage params translations error) ] - in case error of - CustomError key -> errorElement key [] - SmallerIntThan n -> errorElement "SmallerIntThan" [toString n] - GreaterIntThan n -> errorElement "GreaterIntThan" [toString n] - error -> errorElement (toString error) [] - Nothing -> - text "" - -hiddenSubmit : msg -> Html msg -hiddenSubmit msg = - button - [ style [ ("display", "none") ] - , onClick msg - ] - [] diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 12fb87c..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,60 +0,0 @@ -module View.Header exposing - ( view - ) - -import Dict - -import FontAwesome -import View.Color as Color - -import Page exposing (..) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Msg exposing (..) -import Model.View exposing (..) - -view : Model -> Html Msg -view model = - header - [] - ( [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ] - ++ let item page name = - a - [ href (Page.toHash page) - , classList - [ ("item", True) - , ("current", model.page == page) - ] - ] - [ text (getMessage model.translations name) - ] - in case model.view of - LoggedInView { me, users } -> - [ item Home "PaymentsTitle" - , item Income "Income" - , item Categories "Categories" - , item Statistics "Statistics" - , div - [ class "nameSignOut" ] - [ div - [ class "name" ] - [ Dict.get me users - |> Maybe.map .name - |> Maybe.withDefault "" - |> text - ] - , button - [ class "signOut item" - , onClick SignOut - ] - [ FontAwesome.power_off Color.white 30 ] - ] - ] - _ -> - [] - ) diff --git a/src/client/View/Plural.elm b/src/client/View/Plural.elm deleted file mode 100644 index c36eaca..0000000 --- a/src/client/View/Plural.elm +++ /dev/null @@ -1,11 +0,0 @@ -module View.Plural exposing - ( plural - ) - -import Model.Translations exposing (Translations, getMessage) - -plural : Translations -> Int -> String -> String -> String -plural translations n single multiple = - let singleMessage = getMessage translations single - multipleMessage = getMessage translations multiple - in (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage 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/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/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/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/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/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/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/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/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/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/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/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 diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index b72f9a0..0000000 --- a/stack.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-8.3 -extra-deps: -- config-manager-0.3.0.1 diff --git a/tools.nix b/tools.nix new file mode 100644 index 0000000..9a506c7 --- /dev/null +++ b/tools.nix @@ -0,0 +1,13 @@ +with import <nixpkgs> {}; { + env = stdenv.mkDerivation { + name = "tools"; + buildInputs = with pkgs; with nodePackages; [ + nodemon + sqlite + cabal-install + tmux + tmuxinator + haskellPackages.stylish-haskell + ]; + }; +} diff --git a/validation/LICENSE b/validation/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/validation/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + <program> Copyright (C) <year> <name of author> + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +<http://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/validation/Setup.hs b/validation/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/validation/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/validation/src/Data/Validation.hs b/validation/src/Data/Validation.hs new file mode 100644 index 0000000..e30202f --- /dev/null +++ b/validation/src/Data/Validation.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +#endif + +-- | A data type similar to @Data.Either@ that accumulates failures. +module Data.Validation +( + -- * Data type + Validation(..) + -- * Constructing validations +, validate +, validationNel +, fromEither +, liftError + -- * Functions on validations +, validation +, toEither +, orElse +, valueOr +, ensure +, codiagonal +, validationed +, bindValidation + -- * Prisms + -- | These prisms are useful for writing code which is polymorphic in its + -- choice of Either or Validation. This choice can then be made later by a + -- user, depending on their needs. + -- + -- An example of this style of usage can be found + -- <https://github.com/qfpl/validation/blob/master/examples/src/PolymorphicEmail.hs here> +, _Failure +, _Success + -- * Isomorphisms +, Validate(..) +, revalidate +) where + +import Control.Applicative (Applicative (pure, (<*>)), (<$>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Lens (over, under) +import Control.Lens.Getter ((^.)) +import Control.Lens.Iso (Iso, Swapped (..), from, iso) +import Control.Lens.Prism (Prism, prism) +import Control.Lens.Review (( # )) +import Data.Bifoldable (Bifoldable (bifoldr)) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Bitraversable (Bitraversable (bitraverse)) +import Data.Data (Data) +import Data.Either (Either (Left, Right), either) +import Data.Eq (Eq) +import Data.Foldable (Foldable (foldr)) +import Data.Function (id, ($), (.)) +import Data.Functor (Functor (fmap)) +import Data.Functor.Alt (Alt ((<!>))) +import Data.Functor.Apply (Apply ((<.>))) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Ord (Ord) +import Data.Semigroup (Semigroup ((<>))) +import Data.Traversable (Traversable (traverse)) +import Data.Typeable (Typeable) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (Generic) +#endif +import Prelude (Maybe (..), Show) + + +-- | An @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However, +-- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@. +-- In contrast, the @Applicative@ for @Either@ returns only the first error. +-- +-- A consequence of this is that @Validation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because +-- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the +-- @Applicative@'s 'Control.Applicative.<*>' +-- +-- An example of typical usage can be found <https://github.com/qfpl/validation/blob/master/examples/src/Email.hs here>. +-- +data Validation err a = + Failure err + | Success a + deriving ( + Eq, Ord, Show, Data, Typeable +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif + ) + +instance Functor (Validation err) where + fmap _ (Failure e) = + Failure e + fmap f (Success a) = + Success (f a) + {-# INLINE fmap #-} + +instance Semigroup err => Apply (Validation err) where + Failure e1 <.> b = Failure $ case b of + Failure e2 -> e1 <> e2 + Success _ -> e1 + Success _ <.> Failure e2 = + Failure e2 + Success f <.> Success a = + Success (f a) + {-# INLINE (<.>) #-} + +instance Semigroup err => Applicative (Validation err) where + pure = + Success + (<*>) = + (<.>) + +-- | For two errors, this instance reports only the last of them. +instance Alt (Validation err) where + Failure _ <!> x = + x + Success a <!> _ = + Success a + {-# INLINE (<!>) #-} + +instance Foldable (Validation err) where + foldr f x (Success a) = + f a x + foldr _ x (Failure _) = + x + {-# INLINE foldr #-} + +instance Traversable (Validation err) where + traverse f (Success a) = + Success <$> f a + traverse _ (Failure e) = + pure (Failure e) + {-# INLINE traverse #-} + +instance Bifunctor Validation where + bimap f _ (Failure e) = + Failure (f e) + bimap _ g (Success a) = + Success (g a) + {-# INLINE bimap #-} + + +instance Bifoldable Validation where + bifoldr _ g x (Success a) = + g a x + bifoldr f _ x (Failure e) = + f e x + {-# INLINE bifoldr #-} + +instance Bitraversable Validation where + bitraverse _ g (Success a) = + Success <$> g a + bitraverse f _ (Failure e) = + Failure <$> f e + {-# INLINE bitraverse #-} + +appValidation :: + (err -> err -> err) + -> Validation err a + -> Validation err a + -> Validation err a +appValidation m (Failure e1) (Failure e2) = + Failure (e1 `m` e2) +appValidation _ (Failure _) (Success a2) = + Success a2 +appValidation _ (Success a1) (Failure _) = + Success a1 +appValidation _ (Success a1) (Success _) = + Success a1 +{-# INLINE appValidation #-} + +instance Semigroup e => Semigroup (Validation e a) where + (<>) = + appValidation (<>) + {-# INLINE (<>) #-} + +instance Monoid e => Monoid (Validation e a) where + mappend = + appValidation mappend + {-# INLINE mappend #-} + mempty = + Failure mempty + {-# INLINE mempty #-} + +instance Swapped Validation where + swapped = + iso + (\v -> case v of + Failure e -> Success e + Success a -> Failure a) + (\v -> case v of + Failure a -> Success a + Success e -> Failure e) + {-# INLINE swapped #-} + +instance (NFData e, NFData a) => NFData (Validation e a) where + rnf v = + case v of + Failure e -> rnf e + Success a -> rnf a + +-- | 'validate's an @a@ producing an updated optional value, returning +-- @e@ in the empty case. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- validate :: e -> (a -> Maybe b) -> a -> Validation e b +-- @ +validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b +validate e p a = case p a of + Nothing -> _Failure # e + Just b -> _Success # b + +-- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since +-- they are a common semigroup to use. +validationNel :: Either e a -> Validation (NonEmpty e) a +validationNel = liftError pure + +-- | Converts from 'Either' to 'Validation'. +fromEither :: Either e a -> Validation e a +fromEither = liftError id + +-- | 'liftError' is useful for converting an 'Either' to an 'Validation' +-- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'. +liftError :: (b -> e) -> Either b a -> Validation e a +liftError f = either (Failure . f) Success + +-- | 'validation' is the catamorphism for @Validation@. +validation :: (e -> c) -> (a -> c) -> Validation e a -> c +validation ec ac v = case v of + Failure e -> ec e + Success a -> ac a + +-- | Converts from 'Validation' to 'Either'. +toEither :: Validation e a -> Either e a +toEither = validation Left Right + +-- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- orElse :: Validation e a -> a -> a +-- @ +orElse :: Validate v => v e a -> a -> a +orElse v a = case v ^. _Validation of + Failure _ -> a + Success x -> x + +-- | Return the @a@ or run the given function over the @e@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- valueOr :: (e -> a) -> Validation e a -> a +-- @ +valueOr :: Validate v => (e -> a) -> v e a -> a +valueOr ea v = case v ^. _Validation of + Failure e -> ea e + Success a -> a + +-- | 'codiagonal' gets the value out of either side. +codiagonal :: Validation a a -> a +codiagonal = valueOr id + +-- | 'ensure' ensures that a validation remains unchanged upon failure, +-- updating a successful validation with an optional value that could fail +-- with @e@ otherwise. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b +-- @ +ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b +ensure e p = + over _Validation $ \v -> case v of + Failure x -> Failure x + Success a -> validate e p a + +-- | Run a function on anything with a Validate instance (usually Either) +-- as if it were a function on Validation +-- +-- This can be thought of as having the type +-- +-- @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@ +validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a' +validationed f = under _Validation f + +-- | @bindValidation@ binds through an Validation, which is useful for +-- composing Validations sequentially. Note that despite having a bind +-- function of the correct type, Validation is not a monad. +-- The reason is, this bind does not accumulate errors, so it does not +-- agree with the Applicative instance. +-- +-- There is nothing wrong with using this function, it just does not make a +-- valid @Monad@ instance. +bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b +bindValidation v f = case v of + Failure e -> Failure e + Success a -> f a + +-- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic +-- to Validation, and hence isomorphic to Either. +class Validate f where + _Validation :: + Iso (f e a) (f g b) (Validation e a) (Validation g b) + + _Either :: + Iso (f e a) (f g b) (Either e a) (Either g b) + _Either = + iso + (\x -> case x ^. _Validation of + Failure e -> Left e + Success a -> Right a) + (\x -> _Validation # case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Validation where + _Validation = + id + {-# INLINE _Validation #-} + _Either = + iso + (\x -> case x of + Failure e -> Left e + Success a -> Right a) + (\x -> case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Either where + _Validation = + iso + fromEither + toEither + {-# INLINE _Validation #-} + _Either = + id + {-# INLINE _Either #-} + +-- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'. +_Failure :: + Validate f => + Prism (f e1 a) (f e2 a) e1 e2 +_Failure = + prism + (\x -> _Either # Left x) + (\x -> case x ^. _Either of + Left e -> Right e + Right a -> Left (_Either # Right a)) +{-# INLINE _Failure #-} + +-- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'. +_Success :: + Validate f => + Prism (f e a) (f e b) a b +_Success = + prism + (\x -> _Either # Right x) + (\x -> case x ^. _Either of + Left e -> Left (_Either # Left e) + Right a -> Right a) +{-# INLINE _Success #-} + +-- | 'revalidate' converts between any two instances of 'Validate'. +revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) +revalidate = _Validation . from _Validation diff --git a/validation/validation.cabal b/validation/validation.cabal new file mode 100644 index 0000000..60e5444 --- /dev/null +++ b/validation/validation.cabal @@ -0,0 +1,23 @@ +name: validation +version: 1 +license: BSD3 +license-file: LICENSE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>, Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ> +synopsis: A data-type like Either but with an accumulating Applicative +category: Data +cabal-version: >= 1.10 +build-type: Simple + +library + Default-Language: Haskell2010 + Build-Depends: + base >= 4.5 && < 5 + , deepseq >= 1.2 && < 1.5 + , semigroups >= 0.8 && < 1 + , semigroupoids >= 5 && < 6 + , bifunctors >= 5.1 && < 6 + , lens >= 4 && < 5 + Ghc-Options: -Wall + Hs-Source-Dirs: src + Exposed-Modules: Data.Validation |