diff options
100 files changed, 1067 insertions, 929 deletions
diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..3642d0e --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,30 @@ +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 + - MultiParamTypeClasses @@ -29,7 +29,7 @@ cp-client: @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.1 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -48,4 +48,4 @@ run-server: @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --delay 0.1 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/client/Setup.hs b/client/Setup.hs index 9a994af..4467109 100644 --- a/client/Setup.hs +++ b/client/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/client/client.cabal b/client/client.cabal index 9d3e873..ac74d9c 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -1,34 +1,41 @@ -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 +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 - build-depends: aeson - , base >=4.9 && <4.11 - , bytestring - , common - , containers - , jsaddle-dom - , reflex-dom - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Component.Button - , Component.Input - , Icon - , Main - , View.App - , View.Header - , View.Payment - , View.Payment.Pages - , View.Payment.Table - , View.SignIn +Executable client + Main-Is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , jsaddle-dom + , reflex-dom + , text + , time + + other-modules: + Component.Button + Component.Input + Icon + Main + View.App + View.Header + View.Payment + View.Payment.Pages + View.Payment.Table + View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs new file mode 100644 index 0000000..4c9541b --- /dev/null +++ b/client/src/Component.hs @@ -0,0 +1,4 @@ +module Component (module X) where + +import Component.Button as X +import Component.Input as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index f21798c..9499045 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Button ( ButtonIn(..) @@ -8,17 +7,17 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7111630..c3864b4 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Input ( InputIn(..) @@ -7,12 +6,12 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) import qualified Reflex.Dom as R data InputIn t a b = InputIn - { _inputIn_reset :: Event t a + { _inputIn_reset :: Event t a , _inputIn_placeHolder :: Text } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 6b2749a..cd5a0b4 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Icon ( clone @@ -13,10 +12,10 @@ module Icon , signOut ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) +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 () diff --git a/client/src/Main.hs b/client/src/Main.hs index 14f0fee..cbc881c 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -2,22 +2,22 @@ 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 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 (JSM, HTMLElement(..)) -import qualified JSDOM.Types as Dom -import Prelude hiding (init, error) +import JSDOM.Types (HTMLElement (..), JSM) +import qualified JSDOM.Types as Dom +import Prelude hiding (error, init) -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult (InitEmpty)) -import qualified View.App as App +import qualified View.App as App main :: JSM () main = do @@ -33,7 +33,7 @@ readInit = do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init - Nothing -> initParseError + Nothing -> initParseError _ -> return initParseError where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1466811..442fa3e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.App ( widget ) where -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import Common.Model (InitResult(..)) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key +import Common.Model (InitResult (..)) -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 705e054..711ba80 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Header ( view @@ -8,19 +7,19 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -55,7 +54,7 @@ nameSignOut initResult = case initResult of 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 + Nothing -> R.blank signOutButton return signOut diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index d1430c9..f70c8cd 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment ( widget @@ -8,14 +7,14 @@ module View.Payment , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init(..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn(..)) +import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn(..)) +import View.Payment.Table (TableIn (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -29,10 +28,12 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - _ <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn - } + rec + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pagesOut + } + pagesOut <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f9a2b4e..cf3e115 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Pages ( widget @@ -8,35 +7,45 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Event, Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment(..)) +import Common.Model (Payment (..)) +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon data PagesIn = PagesIn { _pagesIn_payments :: [Payment] } -data PagesOut = PagesOut - { +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) widget _ = do - R.divClass "pages" $ do - page Icon.doubleLeftBar - page Icon.doubleLeft - page (R.text . T.pack . show $ (1 :: Integer)) - page (R.text . T.pack . show $ (2 :: Integer)) - page (R.text . T.pack . show $ (3 :: Integer)) - page (R.text . T.pack . show $ (4 :: Integer)) - page (R.text . T.pack . show $ (5 :: Integer)) - page Icon.doubleRight - page Icon.doubleRightBar - return $ PagesOut {} - -page :: forall t m. MonadWidget t m => m () -> m () -page content = R.elClass "button" "page" $ content + currentPage <- R.divClass "pages" $ do + a <- page 1 Icon.doubleLeftBar + b <- page 1 Icon.doubleLeft + c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) + d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) + e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) + f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) + g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) + h <- page 5 Icon.doubleRight + i <- page 5 Icon.doubleRightBar + R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + +page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) +page n content = + ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn + { _buttonIn_class = "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f3eb9a7..734511d 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Table ( widget @@ -8,34 +7,40 @@ module View.Payment.Table , TableOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget, Dynamic) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T import qualified Common.View.Format as Format import qualified Icon -data TableIn = TableIn +data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int } data TableOut = TableOut { } -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +visiblePayments :: Int +visiblePayments = 8 + +widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.divClass "table" $ + R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) + _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name @@ -48,39 +53,50 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) + paymentRange = fmap + (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) + (_tableIn_currentPage tableIn) + R.simpleList paymentRange (paymentRow init) return $ TableOut {} -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell name" . R.dynText . fmap _payment_name $ payment + R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment + + let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) R.divClass "cell user" $ - case CM.findUser (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank + R.dynText $ flip fmap user $ \mbUser -> case mbUser of + Just u -> _user_name u + _ -> "" + + let category = flip fmap payment $ \p -> findCategory + (_init_categories init) + (_init_paymentCategories init) + (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of + Just c -> M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ + R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + Just c -> _category_name c + _ -> "" + R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment + R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank + let modifyAttrs = flip fmap payment $ \p -> + M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.edit + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.delete findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index e164ee7..70c6b1f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) +import Common.Model (SignIn (SignIn)) -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -75,11 +73,11 @@ showSignInResult result signInResult = do _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error + where showInitResult (Left error) = showError error showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + showInitResult (Right Nothing) = R.blank - showResult (Left error) = showError error + showResult (Left error) = showError error showResult (Right success) = showSuccess success showError = R.divClass "error" . R.text diff --git a/common/Setup.hs b/common/Setup.hs index 9a994af..4467109 100644 --- a/common/Setup.hs +++ b/common/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/common/common.cabal b/common/common.cabal index 8b60743..c3073d9 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -1,41 +1,47 @@ -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 +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 - build-depends: aeson - , base >=4.9 && <4.11 - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - exposed-modules: Common.Message - , Common.Message.Key - , Common.Model - , Common.Util.Text - , Common.View.Format - other-modules: Common.Message.Lang - , Common.Message.Translation - , Common.Model.PaymentCategory - , Common.Model.CreateCategory - , Common.Model.CreatePayment - , Common.Model.CreateIncome - , Common.Model.EditCategory - , Common.Model.EditPayment - , Common.Model.InitResult - , Common.Model.EditIncome - , Common.Model.Frequency - , Common.Model.Currency - , Common.Model.Category - , Common.Model.Payment - , Common.Model.Income - , Common.Model.SignIn - , Common.Model.Init - , Common.Model.User +Library + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + + Build-depends: + aeson + , base >=4.9 && <4.11 + , text + , time + + Exposed-modules: + Common.Message + Common.Message.Key + Common.Model + Common.Util.Text + Common.View.Format + + other-modules: + Common.Message.Lang + Common.Message.Translation + Common.Model.PaymentCategory + Common.Model.CreateCategory + Common.Model.CreatePayment + Common.Model.CreateIncome + Common.Model.EditCategory + Common.Model.EditPayment + Common.Model.InitResult + Common.Model.EditIncome + Common.Model.Frequency + Common.Model.Currency + Common.Model.Category + Common.Model.Payment + Common.Model.Income + Common.Model.SignIn + Common.Model.Init + Common.Model.User diff --git a/common/src/Common/Message.hs b/common/src/Common/Message.hs index 9ae735d..745e457 100644 --- a/common/src/Common/Message.hs +++ b/common/src/Common/Message.hs @@ -2,10 +2,10 @@ module Common.Message ( get ) where -import Data.Text (Text) +import Data.Text (Text) -import Common.Message.Key (Key) -import Common.Message.Lang (Lang(..)) +import Common.Message.Key (Key) +import Common.Message.Lang (Lang (..)) import qualified Common.Message.Translation as Translation get :: Key -> Text diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 4127808..991c407 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -2,7 +2,7 @@ module Common.Message.Key ( Key(..) ) where -import Data.Text +import Data.Text data Key = diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 900a9e9..16a56dd 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -4,11 +4,11 @@ module Common.Message.Translation ( get ) where -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T -import Common.Message.Key -import Common.Message.Lang (Lang(..)) +import Common.Message.Key +import Common.Message.Lang (Lang (..)) get :: Lang -> Key -> Text get = m @@ -162,7 +162,7 @@ m l Form_AlreadyExists = m l Form_CostMustNotBeNull = case l of English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" + French -> "Le coût ne doît pas être nul" m l Form_Empty = case l of @@ -462,7 +462,7 @@ m l Payment_PunctualMale = m l Payment_Title = case l of English -> "Payments" - French -> "Paiements" + French -> "Paiements" m l Payment_User = case l of @@ -472,7 +472,7 @@ m l Payment_User = m l (Payment_Worth subject amount) = case l of English -> T.concat [ subject, " worth ", amount ] - French -> T.concat [ subject, " comptabilisant ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] m l Search_Monthly = case l of @@ -517,7 +517,7 @@ m l SignIn_EmailInvalid = m l SignIn_EmailPlaceholder = case l of English -> "Email" - French -> "Courriel" + French -> "Courriel" m l SignIn_EmailSendFail = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 80c344b..20e86c1 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -1,18 +1,18 @@ module Common.Model (module X) where -import Common.Model.Category as X -import Common.Model.CreateCategory as X -import Common.Model.CreateIncome as X -import Common.Model.CreatePayment as X -import Common.Model.Currency as X -import Common.Model.EditCategory as X -import Common.Model.EditIncome as X -import Common.Model.EditPayment as X -import Common.Model.Frequency as X -import Common.Model.Income as X -import Common.Model.Init as X -import Common.Model.InitResult as X -import Common.Model.Payment as X -import Common.Model.PaymentCategory as X -import Common.Model.SignIn as X -import Common.Model.User as X +import Common.Model.Category as X +import Common.Model.CreateCategory as X +import Common.Model.CreateIncome as X +import Common.Model.CreatePayment as X +import Common.Model.Currency as X +import Common.Model.EditCategory as X +import Common.Model.EditIncome as X +import Common.Model.EditPayment as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payment as X +import Common.Model.PaymentCategory as X +import Common.Model.SignIn as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index 53a6bdb..bbd3c33 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -5,20 +5,20 @@ module Common.Model.Category , Category(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +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_id :: CategoryId + , _category_name :: Text + , _category_color :: Text , _category_createdAt :: UTCTime - , _category_editedAt :: Maybe UTCTime + , _category_editedAt :: Maybe UTCTime , _category_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs index bfe24c5..11d84e9 100644 --- a/common/src/Common/Model/CreateCategory.hs +++ b/common/src/Common/Model/CreateCategory.hs @@ -4,12 +4,12 @@ module Common.Model.CreateCategory ( CreateCategory(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) data CreateCategory = CreateCategory - { _createCategory_name :: Text + { _createCategory_name :: Text , _createCategory_color :: Text } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs index 4ee3a50..583ebbb 100644 --- a/common/src/Common/Model/CreateIncome.hs +++ b/common/src/Common/Model/CreateIncome.hs @@ -4,12 +4,12 @@ module Common.Model.CreateIncome ( CreateIncome(..) ) where -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) data CreateIncome = CreateIncome - { _createIncome_date :: Day + { _createIncome_date :: Day , _createIncome_amount :: Int } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index b5b6256..7a283e5 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -4,19 +4,19 @@ module Common.Model.CreatePayment ( CreatePayment(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId , _createPayment_frequency :: Frequency } deriving (Show, Generic) diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs index 7c12545..6d74ea7 100644 --- a/common/src/Common/Model/Currency.hs +++ b/common/src/Common/Model/Currency.hs @@ -4,9 +4,9 @@ module Common.Model.Currency ( Currency(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) newtype Currency = Currency Text deriving (Show, Generic) diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs index 2a3a697..5b08b86 100644 --- a/common/src/Common/Model/EditCategory.hs +++ b/common/src/Common/Model/EditCategory.hs @@ -4,15 +4,15 @@ module Common.Model.EditCategory ( EditCategory(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) +import Common.Model.Category (CategoryId) data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text + { _editCategory_id :: CategoryId + , _editCategory_name :: Text , _editCategory_color :: Text } deriving (Show, Generic) diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs index a55c39e..867b406 100644 --- a/common/src/Common/Model/EditIncome.hs +++ b/common/src/Common/Model/EditIncome.hs @@ -4,15 +4,15 @@ module Common.Model.EditIncome ( EditIncome(..) ) where -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Income (IncomeId) +import Common.Model.Income (IncomeId) data EditIncome = EditIncome - { _editIncome_id :: IncomeId - , _editIncome_date :: Day + { _editIncome_id :: IncomeId + , _editIncome_date :: Day , _editIncome_amount :: Int } deriving (Show, Generic) diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs index 172c0c1..32228f0 100644 --- a/common/src/Common/Model/EditPayment.hs +++ b/common/src/Common/Model/EditPayment.hs @@ -4,21 +4,21 @@ module Common.Model.EditPayment ( EditPayment(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId , _editPayment_frequency :: Frequency } deriving (Show, Generic) diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index 7c46605..085163d 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -4,8 +4,8 @@ module Common.Model.Frequency ( Frequency(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) data Frequency = Punctual diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs index 280812f..10b4cf2 100644 --- a/common/src/Common/Model/Income.hs +++ b/common/src/Common/Model/Income.hs @@ -5,23 +5,23 @@ module Common.Model.Income , 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 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) +import Common.Model.User (UserId) type IncomeId = Int64 data Income = Income - { _income_id :: IncomeId - , _income_userId :: UserId - , _income_date :: Day - , _income_amount :: Int + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int , _income_createdAt :: UTCTime - , _income_editedAt :: Maybe UTCTime + , _income_editedAt :: Maybe UTCTime , _income_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs index 68fcfb8..ae23bb5 100644 --- a/common/src/Common/Model/Init.hs +++ b/common/src/Common/Model/Init.hs @@ -4,24 +4,24 @@ module Common.Model.Init ( Init(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (UserId, User) +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (User, UserId) data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency + , _init_currency :: Currency } deriving (Show, Generic) instance FromJSON Init diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 43c16f9..12be65a 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -4,11 +4,11 @@ module Common.Model.InitResult ( InitResult(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) -import Common.Model.Init (Init) +import Common.Model.Init (Init) data InitResult = InitSuccess Init diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 804b501..4741058 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -5,27 +5,27 @@ module Common.Model.Payment , 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 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.Frequency -import Common.Model.User (UserId) +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_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day , _payment_frequency :: Frequency , _payment_createdAt :: UTCTime - , _payment_editedAt :: Maybe UTCTime + , _payment_editedAt :: Maybe UTCTime , _payment_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs index a0e94f9..24cf9e1 100644 --- a/common/src/Common/Model/PaymentCategory.hs +++ b/common/src/Common/Model/PaymentCategory.hs @@ -5,22 +5,22 @@ module Common.Model.PaymentCategory , PaymentCategory(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) +import Common.Model.Category (CategoryId) type PaymentCategoryId = Int64 data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime } deriving (Show, Generic) instance FromJSON PaymentCategory diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs index f4da97f..baccd88 100644 --- a/common/src/Common/Model/SignIn.hs +++ b/common/src/Common/Model/SignIn.hs @@ -4,9 +4,9 @@ module Common.Model.SignIn ( SignIn(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) data SignIn = SignIn { _signIn_email :: Text diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs index 694c70e..e491c31 100644 --- a/common/src/Common/Model/User.hs +++ b/common/src/Common/Model/User.hs @@ -6,20 +6,20 @@ module Common.Model.User , findUser ) where -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List as L -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +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_id :: UserId , _user_creation :: UTCTime - , _user_email :: Text - , _user_name :: Text + , _user_email :: Text + , _user_name :: Text } deriving (Show, Generic) instance FromJSON User diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index 4af7a4c..7e5c8c2 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -2,7 +2,7 @@ module Common.Util.Text ( unaccent ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T unaccent :: Text -> Text @@ -38,4 +38,4 @@ unaccentChar c = case c of 'ý' -> 'y' 'ÿ' -> 'y' 'ž' -> 'z' - _ -> c + _ -> c diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs index 7165965..783ad67 100644 --- a/common/src/Common/View/Format.hs +++ b/common/src/Common/View/Format.hs @@ -7,15 +7,15 @@ module Common.View.Format , number ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, toGregorian) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day, toGregorian) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Currency(..)) +import Common.Model (Currency (..)) shortDay :: Day -> Text shortDay date = @@ -45,7 +45,7 @@ longDay date = monthToKey 10 = Just Key.Month_October monthToKey 11 = Just Key.Month_November monthToKey 12 = Just Key.Month_December - monthToKey _ = Nothing + monthToKey _ = Nothing price :: Currency -> Int -> Text price (Currency currency) amount = T.concat [ number amount, " ", currency ] diff --git a/result-client b/result-client deleted file mode 120000 index 157e7ca..0000000 --- a/result-client +++ /dev/null @@ -1 +0,0 @@ -/nix/store/j41w9i28pasvvy6dgqrygj34s30hscad-client-0.0.1
\ No newline at end of file diff --git a/result-server b/result-server deleted file mode 120000 index 561c4ee..0000000 --- a/result-server +++ /dev/null @@ -1 +0,0 @@ -/nix/store/6myvk196ip9xv91xi04g43zbqis84a1i-server-0.0.1
\ No newline at end of file diff --git a/server/Setup.hs b/server/Setup.hs index 9a994af..4467109 100644 --- a/server/Setup.hs +++ b/server/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/server/server.cabal b/server/server.cabal index 41b2fd6..d30060b 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -1,103 +1,110 @@ -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 +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 - build-depends: aeson - , base >=4.9 && <4.11 - , base64-bytestring - , blaze-builder - , blaze-html - , bytestring - , clay - , clientsession - , common - , config-manager - , containers - , cookie - , email-validate - , filepath - , http-conduit - , http-types - , lens - , monad-logger - , mtl - , parsec - , process - , random - , resourcet - , scotty - , sqlite-simple - , text - , time - , transformers - , unordered-containers - , uuid - , wai - , wai-extra - , wai-middleware-static - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Conf - , Controller.Category - , Controller.Income - , Controller.Index - , Controller.Payment - , Controller.SignIn - , Cookie - , Design.Color - , Design.Constants - , Design.Dialog - , Design.Errors - , Design.Form - , Design.Global - , Design.Helper - , Design.Media - , Design.Tooltip - , Design.View.Header - , Design.View.Payment - , Design.View.Payment.Header - , Design.View.Payment.Pages - , Design.View.Payment.Table - , Design.View.SignIn - , Design.View.Stat - , Design.View.Table - , Design.Views - , Job.Daemon - , Job.Frequency - , Job.Kind - , Job.Model - , Job.MonthlyPayment - , Job.WeeklyReport - , Json - , LoginSession - , Main - , MimeMail - , Model.Category - , Model.Frequency - , Model.Income - , Model.Init - , Model.Mail - , Model.Payer - , Model.Payment - , Model.PaymentCategory - , Model.Query - , Model.SignIn - , Model.UUID - , Model.User - , Resource - , Secure - , SendMail - , Utils.Time - , Validation - , View.Mail.SignIn - , View.Mail.WeeklyReport - , View.Page +Executable server + Main-is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , base64-bytestring + , blaze-builder + , blaze-html + , bytestring + , clay + , clientsession + , common + , config-manager + , containers + , cookie + , email-validate + , filepath + , http-conduit + , http-types + , lens + , monad-logger + , mtl + , parsec + , process + , random + , resourcet + , scotty + , sqlite-simple + , text + , time + , transformers + , unordered-containers + , uuid + , wai + , wai-extra + , wai-middleware-static + + other-modules: + Conf + Controller.Category + Controller.Income + Controller.Index + Controller.Payment + Controller.SignIn + Cookie + Design.Color + Design.Constants + Design.Dialog + Design.Errors + Design.Form + Design.Global + Design.Helper + Design.Media + Design.Tooltip + Design.View.Header + Design.View.Payment + Design.View.Payment.Header + Design.View.Payment.Pages + Design.View.Payment.Table + Design.View.SignIn + Design.View.Stat + Design.View.Table + Design.Views + Job.Daemon + Job.Frequency + Job.Kind + Job.Model + Job.MonthlyPayment + Job.WeeklyReport + Json + LoginSession + Main + MimeMail + Model.Category + Model.Frequency + Model.Income + Model.Init + Model.Mail + Model.Payer + Model.Payment + Model.PaymentCategory + Model.Query + Model.SignIn + Model.UUID + Model.User + Resource + Secure + SendMail + Utils.Time + Validation + View.Mail.SignIn + View.Mail.WeeklyReport + View.Page diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 26c5c28..299f071 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -5,20 +5,20 @@ module Conf , 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(..)) +import Common.Model (Currency (..)) data Conf = Conf - { hostname :: Text - , port :: Int + { hostname :: Text + , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool + , currency :: Currency + , noReplyMail :: Text + , https :: Bool } deriving Show get :: FilePath -> IO Conf @@ -36,4 +36,4 @@ get path = do ) 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 index d6ed2f2..a646496 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -6,19 +6,20 @@ module Controller.Category , 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 Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure create :: CreateCategory -> ActionM () diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 148b713..c42f6a7 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -6,18 +6,19 @@ module Controller.Income , 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 Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome (..), EditIncome (..), + IncomeId, User (..)) -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query import qualified Secure create :: CreateIncome -> ActionM () diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 8473c5c..bf4859d 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -3,26 +3,26 @@ module Controller.Index , signOut ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult (..), User (..)) -import Conf (Conf(..)) -import Model.Init (getInit) +import Conf (Conf (..)) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) +import Model.Init (getInit) +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 @@ -70,7 +70,7 @@ validateSignIn conf textToken = do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index dc10311..e4104eb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -7,16 +7,18 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty + +import Common.Model (CreatePayment (..), + EditPayment (..), PaymentId, + User (..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure list :: ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 0086fa5..5552781 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -4,25 +4,25 @@ module Controller.SignIn ( signIn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import qualified 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 +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn signIn :: Conf -> SignIn -> ActionM () signIn conf (SignIn email) = @@ -41,7 +41,7 @@ signIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail Nothing -> textKey badRequest400 Key.Secure_Unauthorized else textKey badRequest400 Key.SignIn_EmailInvalid where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs index 96d45da..511dd42 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -9,25 +9,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/Color.hs b/server/src/Design/Color.hs index 9a5797f..e7f5aec 100644 --- a/server/src/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,8 +1,8 @@ module Design.Color where -import Clay +import Clay import qualified Clay.Color as C -import Data.Text (Text) +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs index 4e2b8cc..a3123d9 100644 --- a/server/src/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/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 4678633..6759606 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -4,9 +4,9 @@ module Design.Dialog ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 57aaeee..2c6c16b 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -4,9 +4,9 @@ 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/server/src/Design/Form.hs b/server/src/Design/Form.hs index ebb8ac8..a4a1de0 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -4,11 +4,11 @@ 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 diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 47ea4a9..1fe6a80 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -4,20 +4,20 @@ module Design.Global ( globalDesign ) where -import Clay +import Clay -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text) -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip +import qualified Design.Dialog as Dialog +import qualified Design.Errors as Errors +import qualified Design.Form as Form +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media globalDesign :: Text globalDesign = renderWith compact [] global diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 41528ed..0913511 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -9,12 +9,12 @@ module Design.Helper , verticalCentering ) where -import Prelude hiding (span) +import Prelude hiding (span) -import Clay hiding (button, input) +import Clay hiding (button, input) -import Design.Constants -import Design.Color as Color +import Design.Color as Color +import Design.Constants clearFix :: Css clearFix = diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs index 77220ee..19a3b8c 100644 --- a/server/src/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/Tooltip.hs b/server/src/Design/Tooltip.hs index 1da8764..57aec33 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -4,9 +4,9 @@ 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/Header.hs b/server/src/Design/View/Header.hs index 20627e6..d05f748 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -4,13 +4,13 @@ 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.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index d3c7650..62f7061 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,11 +4,11 @@ module Design.View.Payment ( design ) where -import Clay +import Clay import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Table as Table design :: Css design = do diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index f02da8a..d87e95b 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -4,16 +4,16 @@ module Design.View.Payment.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Constants +import Design.Constants -import qualified Design.Helper as Helper -import qualified Design.Color as Color +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index 5fc13f0..f6660a1 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -4,12 +4,12 @@ module Design.View.Payment.Pages ( design ) where -import Clay +import Clay -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index f8326e4..243d7f4 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -4,7 +4,7 @@ module Design.View.Payment.Table ( design ) where -import Clay +import Clay import qualified Design.Color as Color import qualified Design.Media as Media diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 214e663..2b1252f 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -4,12 +4,12 @@ module Design.View.SignIn ( design ) where -import Clay -import Data.Monoid ((<>)) +import Clay +import Data.Monoid ((<>)) -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Helper as Helper design :: Css design = do diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index 0a5b258..b10dd7b 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -4,7 +4,7 @@ module Design.View.Stat ( design ) where -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 95abf90..fd55656 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -4,11 +4,11 @@ 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 diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index bc6ac83..1157b68 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,18 +4,18 @@ module Design.Views ( design ) where -import Clay +import Clay -import qualified Design.View.Header as Header +import qualified Design.View.Header as Header import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +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 diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 0bc6f6e..26977d1 100644 --- a/server/src/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 Utils.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/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs index 263f6e6..c5bef42 100644 --- a/server/src/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 index af5d4f8..17997f7 100644 --- a/server/src/Job/Kind.hs +++ b/server/src/Job/Kind.hs @@ -2,11 +2,12 @@ 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 +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 @@ -16,7 +17,7 @@ data Kind = 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"] + _ -> Errors [error "SQLText field required for job kind"] instance ToField Kind where toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index e1a3c77..b90dca0 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -7,20 +7,20 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import 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) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ba24cca..8cb1c27 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,13 +2,13 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency(..), Payment(..)) +import Common.Model (Frequency (..), Payment (..)) -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import Utils.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 5737c75..74180df 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,13 +2,13 @@ module Job.WeeklyReport ( weeklyReport ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +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 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 diff --git a/server/src/Json.hs b/server/src/Json.hs index cc6327a..eb5c572 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} {-# 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.Aeson.Types as Json import qualified Data.HashMap.Strict as M -import Web.Scotty +import Data.Int (Int64) +import Data.Text (Text) +import Web.Scotty jsonObject :: [(Text, Json.Value)] -> ActionM () jsonObject = json . Json.Object . M.fromList diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index 6f6d620..beca697 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -6,16 +6,17 @@ module LoginSession , 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 index 96c13ee..5ac68db 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,27 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as LT -import Network.Wai.Middleware.Gzip (GzipFiles(GzipCompress)) -import qualified Network.Wai.Middleware.Gzip as W -import Network.Wai.Middleware.Static -import Web.Scotty +import qualified Data.Text.Lazy as LT +import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) +import qualified Network.Wai.Middleware.Gzip as W +import Network.Wai.Middleware.Static +import Web.Scotty import qualified Conf -import qualified Controller.Category as Category -import qualified Controller.Income as Income -import qualified Controller.Index as Index -import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.SignIn as SignIn +import qualified Data.Time as Time +import Job.Daemon (runDaemons) +import qualified Model.Income as IncomeM +import Model.Payer (getOrderedExceedingPayers) +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query +import qualified Model.User as UserM main :: IO () main = do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 0faaf98..7fe98ed 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -38,31 +38,33 @@ module MimeMail , 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 +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Control.Arrow +import Control.Concurrent (forkIO, newEmptyMVar, + putMVar, takeMVar) +import Control.Exception (ErrorCall (ErrorCall), + throwIO) +import Control.Monad (foldM, void, (<=<)) +import Data.Bits (shiftR, (.&.)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as L +import Data.Char (isAscii, isControl) +import Data.List (intersperse) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Word (Word8) +import System.Exit +import System.FilePath (takeFileName) +import System.IO +import System.Process +import System.Random -- | Generates a random sequence of alphanumerics of the given length. randomString :: RandomGen d => Int -> d -> (String, d) @@ -88,10 +90,10 @@ instance Random Boundary where -- | An entire mail message. data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] + { 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: @@ -100,7 +102,7 @@ data Mail = Mail -- -- Make sure when specifying alternatives to place the most preferred -- version last. - , mailParts :: [Alternatives] + , mailParts :: [Alternatives] } deriving Show @@ -132,13 +134,13 @@ type Alternatives = [Part] -- | A single part of a multipart message. data Part = Part - { partType :: Text -- ^ content type + { 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 + , partHeaders :: Headers + , partContent :: L.ByteString } deriving (Eq, Show) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index 6b7a488..b972ebd 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category @@ -8,16 +8,16 @@ module Model.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Common.Model (Category(..), CategoryId) +import Common.Model (Category (..), CategoryId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow Category where fromRow = Category <$> diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index b334a40..41a325d 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import 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) +import Common.Model (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"] + _ -> Errors [error "SQLText field required for frequency"] instance ToField Frequency where toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index bbe7657..a69112a 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -9,17 +9,19 @@ module Model.Income , modifiedDuring ) where -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Common.Model (Income(..), IncomeId, User(..), UserId) +import Common.Model (Income (..), IncomeId, User (..), + UserId) -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, resourceEditedAt) instance Resource Income where resourceCreatedAt = _income_createdAt diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index 8c6a961..c030c58 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -4,16 +4,16 @@ module Model.Init ( getInit ) where -import Common.Model (Init(Init), User(..)) +import Common.Model (Init (Init), User (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment +import qualified Model.Category as Category +import qualified Model.Income as Income +import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.User as User +import Model.Query (Query) +import qualified Model.User as User getInit :: User -> Conf -> Query Init getInit user conf = diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs index 9a4db73..a19f9ae 100644 --- a/server/src/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] - , subject :: Text + { from :: Text + , to :: [Text] + , subject :: Text , plainBody :: Text } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs index de4abd1..db3f37c 100644 --- a/server/src/Model/Payer.hs +++ b/server/src/Model/Payer.hs @@ -2,14 +2,15 @@ module Model.Payer ( getOrderedExceedingPayers ) where -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) +import Common.Model (Income (..), IncomeId, Payment (..), User (..), + UserId) type Users = Map UserId User @@ -20,20 +21,20 @@ type Incomes = Map IncomeId Income type Payments = [Payment] data Payer = Payer - { preIncomePaymentSum :: Int + { preIncomePaymentSum :: Int , postIncomePaymentSum :: Int - , _incomes :: [Income] + , _incomes :: [Income] } data PostPaymentPayer = PostPaymentPayer { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float + , _cumulativeIncome :: Int + , ratio :: Float } data ExceedingPayer = ExceedingPayer { _userId :: UserId - , amount :: Int + , amount :: Int } deriving (Show) getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] @@ -72,7 +73,7 @@ useIncomesFrom users incomes payments = mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes in case (firstPaymentTime, mbIncomeTime) of (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing + _ -> Nothing paymentTime :: Payment -> UTCTime paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date @@ -95,7 +96,7 @@ getPayers currentTime users incomes payments = (\p -> case incomesDefined of Nothing -> False - Just t -> paymentTime p >= t + Just t -> paymentTime p >= t ) userId payments @@ -197,7 +198,7 @@ nominalDay :: NominalDiffTime nominalDay = 86400 safeHead :: [a] -> Maybe a -safeHead [] = Nothing +safeHead [] = Nothing safeHead (x : _) = Just x safeMinimum :: (Ord a) => [a] -> Maybe a diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index 14efe77..c1b109f 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment @@ -13,22 +13,26 @@ module Model.Payment , modifiedDuring ) where -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) -import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Frequency () +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, + resourceEditedAt) instance Resource Payment where resourceCreatedAt = _payment_createdAt diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6e1d304..6d02136 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory @@ -7,17 +7,17 @@ module Model.PaymentCategory , save ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs index d15fb5f..22ae95b 100644 --- a/server/src/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 index c5182f0..6f38fe7 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -8,25 +8,25 @@ module Model.SignIn , 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 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 (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) +import Model.Query (Query (Query)) +import Model.UUID (generateUUID) type SignInId = Int64 data SignIn = SignIn - { id :: SignInId - , token :: Text + { id :: SignInId + , token :: Text , creation :: UTCTime - , email :: Text - , isUsed :: Bool + , email :: Text + , isUsed :: Bool } deriving Show instance FromRow SignIn where diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs index 6cb7ce0..0959a8e 100644 --- a/server/src/Model/UUID.hs +++ b/server/src/Model/UUID.hs @@ -2,9 +2,9 @@ module Model.UUID ( generateUUID ) where -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) +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/Model/User.hs b/server/src/Model/User.hs index e14fcef..f17f545 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User @@ -8,16 +8,16 @@ module Model.User , delete ) where -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Common.Model (UserId, User(..)) +import Common.Model (User (..), UserId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field diff --git a/server/src/Resource.hs b/server/src/Resource.hs index f52bbfa..a12a0f2 100644 --- a/server/src/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 index f427304..88bdcda 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -5,21 +5,21 @@ module Secure , 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 Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) -import Model.Query (Query) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import Model.Query (Query) +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 diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index f7ba3fd..959f21d 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -4,17 +4,17 @@ module SendMail ( sendMail ) where -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) +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 Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified MimeMail as M -import Model.Mail (Mail(Mail)) +import Model.Mail (Mail (Mail)) sendMail :: Mail -> IO (Either Text ()) sendMail mail = do diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs index 97457c7..e1a94d3 100644 --- a/server/src/Utils/Time.hs +++ b/server/src/Utils/Time.hs @@ -4,10 +4,10 @@ module Utils.Time , timeToDay ) where -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do diff --git a/server/src/Validation.hs b/server/src/Validation.hs index 1f332c9..fd739cd 100644 --- a/server/src/Validation.hs +++ b/server/src/Validation.hs @@ -3,7 +3,7 @@ module Validation , number ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T nonEmpty :: Text -> Maybe Text diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index 1daca1e..d542fd8 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -4,15 +4,15 @@ module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (User(..)) +import Common.Model (User (..)) -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index b5f2b67..c0e89d5 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -4,28 +4,29 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T +import 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 qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model as CM +import Common.Model (Income (..), Payment (..), User (..), + UserId) +import qualified Common.Model as CM import qualified Common.View.Format as Format -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Income () +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.Payment () +import Resource (Status (..), groupByStatus, statuses) mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = @@ -65,7 +66,7 @@ payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -85,7 +86,7 @@ isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 6bf9527..ff7bdc7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -4,23 +4,23 @@ 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 Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) -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 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 qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) -import Design.Global (globalDesign) +import Design.Global (globalDesign) page :: InitResult -> Text page initResult = diff --git a/stylish-haskell/default.nix b/stylish-haskell/default.nix new file mode 100644 index 0000000..bd73cf8 --- /dev/null +++ b/stylish-haskell/default.nix @@ -0,0 +1,44 @@ +{ HUnit, aeson, base, bytestring, containers, directory, fetchFromGitHub +, filepath, haskell-src-exts, mkDerivation, mtl, optparse-applicative, stdenv +, strict, stylish-haskell, syb, test-framework, test-framework-hunit, yaml +}: + +let regularDependencies = [ + aeson + base + bytestring + containers + directory + filepath + haskell-src-exts + mtl + syb + yaml + ]; +in mkDerivation { + pname = "stylish-haskell"; + version = "0.8.1.0"; + + src = fetchFromGitHub { + owner = "jaspervdj"; + repo = "stylish-haskell"; + rev = "dc3a73e82c19ff97a1544840dac8f7f4568b24bc"; + sha256 = "0kx9m3j9w2357ff5y651s9cdbjiyax9fksyf4rk8pzabc0dv6dpg"; + }; + + isLibrary = true; + isExecutable = true; + + libraryHaskellDepends = + regularDependencies; + + executableHaskellDepends = + regularDependencies ++ [ optparse-applicative strict stylish-haskell ]; + + testHaskellDepends = + regularDependencies ++ [ HUnit test-framework test-framework-hunit ]; + + homepage = "https://github.com/jaspervdj/stylish-haskell"; + description = "Simple Haskell code prettifier"; + license = stdenv.lib.licenses.bsd3; + } @@ -1,12 +1,17 @@ with import <nixpkgs> {}; { env = stdenv.mkDerivation { name = "tools"; - buildInputs = with pkgs; [ - nodePackages.nodemon + buildInputs = with pkgs; with nodePackages; with haskellPackages; [ + nodemon sqlite cabal-install tmux tmuxinator + (import ./stylish-haskell { + inherit mkDerivation aeson base bytestring containers directory filepath + fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict + optparse-applicative HUnit test-framework test-framework-hunit stdenv; + }) ]; }; } |