From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 3 Jan 2018 17:31:20 +0100
Subject: Modify weelky report and payment search interface

- Add payment balance in weekly report
- Show a message and hide pages when the search results in no results
- Go to page 1 when the search is updated / erased
---
 README.md                            | 27 +++++++++---
 application.conf                     |  1 +
 client/client.cabal                  |  1 -
 client/src/Component/Input.hs        |  2 +-
 client/src/Icon.hs                   |  8 ++--
 client/src/Util/Dom.hs               | 19 +++++++++
 client/src/View/Payment.hs           |  7 +++-
 client/src/View/Payment/Constants.hs |  6 ---
 client/src/View/Payment/Pages.hs     | 51 ++++++++++++++---------
 client/src/View/Payment/Table.hs     | 59 +++++++++++++++-----------
 client/src/View/SignIn.hs            |  4 +-
 server/server.cabal                  |  2 -
 server/src/Conf.hs                   |  4 +-
 server/src/Controller/Index.hs       | 77 ++++++++++++++++++++++++----------
 server/src/Controller/Payment.hs     |  2 +-
 server/src/Controller/SignIn.hs      | 44 --------------------
 server/src/Design/View/SignIn.hs     |  2 +-
 server/src/Job/MonthlyPayment.hs     |  2 +-
 server/src/Job/WeeklyReport.hs       |  7 +---
 server/src/Main.hs                   | 81 +++++++++++++-----------------------
 server/src/Model/Income.hs           | 12 +-----
 server/src/Model/Init.hs             |  2 +-
 server/src/Model/Mail.hs             |  8 ++--
 server/src/Model/Payment.hs          | 41 +++++++-----------
 server/src/SendMail.hs               | 39 +++++++++++++----
 server/src/View/Mail/SignIn.hs       |  2 +-
 server/src/View/Mail/WeeklyReport.hs | 32 +++++++++++---
 server/src/View/Page.hs              |  6 +--
 stylish-haskell/default.nix          | 44 --------------------
 tools.nix                            | 11 ++---
 30 files changed, 302 insertions(+), 301 deletions(-)
 create mode 100644 client/src/Util/Dom.hs
 delete mode 100644 client/src/View/Payment/Constants.hs
 delete mode 100644 server/src/Controller/SignIn.hs
 delete mode 100644 stylish-haskell/default.nix

diff --git a/README.md b/README.md
index aa60885..34ae53e 100644
--- a/README.md
+++ b/README.md
@@ -58,10 +58,25 @@ See [application.conf](application.conf).
 TODO
 ----
 
-- move persistence methods to a module
-- use another route to check the token and redirect to /
-- migration diff (use flyway?)
+### Interface
 
-- Add payment balance in weekly report
-- search by payment category and payment date
-- Move up element ids security (editOwn is actually at db level)
+- Search payments by frequency.
+- Add a payment.
+
+#### Bonus
+
+- Adjust login design.
+- smooth search.
+- search payments by:
+    - category,
+    - date.
+
+### Code
+
+- R.def for custom components.
+- Move up element ids security (editOwn is actually at db level).
+- move persistence methods to a module.
+
+### Tooling
+
+- migration diff (use flyway?).
diff --git a/application.conf b/application.conf
index 49b81a7..021fa2a 100644
--- a/application.conf
+++ b/application.conf
@@ -4,5 +4,6 @@ currency = "€"
 signInExpiration = 5 minutes
 noReplyMail = "no-reply@mail.com"
 https = False
+devMode = True
 
 importMaybe "local.conf"
diff --git a/client/client.cabal b/client/client.cabal
index fdf764e..02a7549 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -39,7 +39,6 @@ Executable client
     View.App
     View.Header
     View.Payment
-    View.Payment.Constants
     View.Payment.Header
     View.Payment.Pages
     View.Payment.Table
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 7eec7d0..24aac22 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -45,7 +45,7 @@ input inputIn =
       R.el "label" $ R.text (_inputIn_label inputIn)
 
       reset <- Button.button $ ButtonIn
-        { _buttonIn_class   = R.constDyn ""
+        { _buttonIn_class   = R.constDyn "reset"
         , _buttonIn_content = Icon.cross
         , _buttonIn_waiting = R.never
         }
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index 555d928..dae5e7f 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -29,8 +29,8 @@ cross =
 
 delete :: forall t m. MonadWidget t m => m ()
 delete =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank
 
 doubleLeft :: forall t m. MonadWidget t m => m ()
 doubleLeft =
@@ -54,8 +54,8 @@ doubleRightBar =
 
 edit :: forall t m. MonadWidget t m => m ()
 edit =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank
 
 loading :: forall t m. MonadWidget t m => m ()
 loading =
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
new file mode 100644
index 0000000..f3e9c88
--- /dev/null
+++ b/client/src/Util/Dom.hs
@@ -0,0 +1,19 @@
+module Util.Dom
+  ( divVisibleIf
+  , divClassVisibleIf
+  ) where
+
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
+divVisibleIf cond content = divClassVisibleIf cond "" content
+
+divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
+divClassVisibleIf cond className content =
+  R.elDynAttr
+    "div"
+    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
+    content
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 8aa4d38..f4aaf5c 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -38,6 +38,8 @@ widget paymentIn = do
             (\s -> filter (filterPayment s) (_init_payments init))
             (_headerOut_search header)
 
+          paymentsPerPage = 7
+
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         }
@@ -46,10 +48,13 @@ widget paymentIn = do
         { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pages
         , _tableIn_payments = payments
+        , _tableIn_perPage = paymentsPerPage
         }
 
       pages <- Pages.widget $ PagesIn
-        { _pagesIn_payments = payments
+        { _pagesIn_total = length <$> payments
+        , _pagesIn_perPage = paymentsPerPage
+        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header
         }
 
     return $ PaymentOut {}
diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs
deleted file mode 100644
index 028e328..0000000
--- a/client/src/View/Payment/Constants.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module View.Payment.Constants
-  ( paymentsPerPage
-  ) where
-
-paymentsPerPage :: Int
-paymentsPerPage = 7
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index dfd92c0..55ceb9f 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -4,20 +4,20 @@ module View.Payment.Pages
   , PagesOut(..)
   ) where
 
-import qualified Data.Text              as T
-import           Reflex.Dom             (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom             as R
+import qualified Data.Text  as T
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
 
-import           Common.Model           (Payment (..))
-
-import           Component              (ButtonIn (..), ButtonOut (..))
-import qualified Component              as Component
+import           Component  (ButtonIn (..), ButtonOut (..))
+import qualified Component  as Component
 
 import qualified Icon
-import qualified View.Payment.Constants as Constants
+import qualified Util.Dom   as Dom
 
 data PagesIn t = PagesIn
-  { _pagesIn_payments :: Dynamic t [Payment]
+  { _pagesIn_total   :: Dynamic t Int
+  , _pagesIn_perPage :: Int
+  , _pagesIn_reset   :: Event t ()
   }
 
 data PagesOut t = PagesOut
@@ -26,9 +26,29 @@ data PagesOut t = PagesOut
 
 widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
 widget pagesIn = do
+  currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
+
+  return $ PagesOut
+    { _pagesOut_currentPage = currentPage
+    }
+
+  where
+    total = _pagesIn_total pagesIn
+    perPage = _pagesIn_perPage pagesIn
+    reset = _pagesIn_reset pagesIn
+
+pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
+pageButtons total perPage reset = do
   R.divClass "pages" $ do
     rec
-      currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ]
+      currentPage <- R.holdDyn 1 . R.leftmost $
+        [ firstPageClic
+        , previousPageClic
+        , pageClic
+        , nextPageClic
+        , lastPageClic
+        , (const 1) <$> reset
+        ]
 
       firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
 
@@ -41,17 +61,10 @@ widget pagesIn = do
 
       lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
 
-    return $ PagesOut
-      { _pagesOut_currentPage = currentPage
-      }
-
-    where maxPage =
-            R.ffor (_pagesIn_payments pagesIn) (\payments ->
-              ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage
-            )
+    return currentPage
 
+    where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
           pageEvent = R.switchPromptlyDyn . fmap R.leftmost
-
           noCurrentPage = R.constDyn Nothing
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 0c3b769..a49be5c 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,28 +4,29 @@ module View.Payment.Table
   , TableOut(..)
   ) where
 
-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             (Dynamic, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category (..), Init (..), Payment (..),
-                                         PaymentCategory (..), User (..))
-import qualified Common.Model           as CM
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Text       as T
-import qualified Common.View.Format     as Format
+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         (Dynamic, MonadWidget)
+import qualified Reflex.Dom         as R
+
+import           Common.Model       (Category (..), Init (..), Payment (..),
+                                     PaymentCategory (..), User (..))
+import qualified Common.Model       as CM
+import qualified Common.Msg         as Msg
+import qualified Common.Util.Text   as T
+import qualified Common.View.Format as Format
 
 import qualified Icon
-import qualified View.Payment.Constants as Constants
+import qualified Util.Dom           as Dom
 
 data TableIn t = TableIn
   { _tableIn_init        :: Init
   , _tableIn_currentPage :: Dynamic t Int
   , _tableIn_payments    :: Dynamic t [Payment]
+  , _tableIn_perPage     :: Int
   }
 
 data TableOut = TableOut
@@ -34,7 +35,8 @@ data TableOut = TableOut
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut
 widget tableIn = do
-  _ <- R.divClass "table" $
+  R.divClass "table" $ do
+
     R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
@@ -45,17 +47,24 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      let init = _tableIn_init tableIn
-          currentPage = _tableIn_currentPage tableIn
-          payments = _tableIn_payments tableIn
-          paymentRange = getPaymentRange <$> payments <*> currentPage
-      R.simpleList paymentRange (paymentRow init)
+      _ <- R.simpleList paymentRange (paymentRow init)
+      return ()
+
+    Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+      R.text $ Msg.get Msg.Payment_Empty
+
   return $ TableOut {}
 
-getPaymentRange :: [Payment] -> Int -> [Payment]
-getPaymentRange payments currentPage =
-  take Constants.paymentsPerPage
-    . drop ((currentPage - 1) * Constants.paymentsPerPage)
+  where
+    init = _tableIn_init tableIn
+    currentPage = _tableIn_currentPage tableIn
+    payments = _tableIn_payments tableIn
+    paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
+
+getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
+getPaymentRange perPage payments currentPage =
+  take perPage
+    . drop ((currentPage - 1) * perPage)
     . reverse
     . L.sortOn _payment_date
     $ payments
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index be6b152..89be737 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -45,7 +45,7 @@ view result =
             ]
 
       button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn ""
+        { _buttonIn_class = R.constDyn "validate"
         , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
         , _buttonIn_waiting = waiting
         }
@@ -57,7 +57,7 @@ view result =
 askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
 askSignIn email =
   fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
+  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
         getResult response =
           case R._xhrResponse_responseText response of
             Just key ->
diff --git a/server/server.cabal b/server/server.cabal
index 3715105..d1dbd50 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -36,7 +36,6 @@ Executable server
     , filepath
     , http-conduit
     , http-types
-    , lens
     , mime-mail
     , monad-logger
     , mtl
@@ -61,7 +60,6 @@ Executable server
     Controller.Income
     Controller.Index
     Controller.Payment
-    Controller.SignIn
     Cookie
     Design.Color
     Design.Constants
diff --git a/server/src/Conf.hs b/server/src/Conf.hs
index 2422a93..ca19c8d 100644
--- a/server/src/Conf.hs
+++ b/server/src/Conf.hs
@@ -17,6 +17,7 @@ data Conf = Conf
   , currency         :: Currency
   , noReplyMail      :: Text
   , https            :: Bool
+  , devMode          :: Bool
   } deriving Show
 
 get :: FilePath -> IO Conf
@@ -30,7 +31,8 @@ get path = do
         Conf.lookup "signInExpiration" conf <*>
         fmap Currency (Conf.lookup "currency" conf) <*>
         Conf.lookup "noReplyMail" conf <*>
-        Conf.lookup "https" conf
+        Conf.lookup "https" conf <*>
+        Conf.lookup "devMode" conf
     )
   case conf of
     Left msg -> error (T.unpack msg)
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index f05ce6f..9a3e2b7 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,16 +1,23 @@
 module Controller.Index
   ( get
+  , askSignIn
+  , trySignIn
   , signOut
   ) where
 
 import           Control.Monad.IO.Class    (liftIO)
 import           Data.Text                 (Text)
+import qualified Data.Text                 as T
+import qualified Data.Text.Encoding        as TE
+import qualified Data.Text.Lazy            as TL
 import           Data.Time.Clock           (diffUTCTime, getCurrentTime)
-import           Network.HTTP.Types.Status (ok200)
+import           Network.HTTP.Types.Status (badRequest400, ok200)
 import           Prelude                   hiding (error)
-import           Web.Scotty                hiding (get)
+import           Web.Scotty                (ActionM)
+import qualified Web.Scotty                as S
 
-import           Common.Model              (InitResult (..), User (..))
+import           Common.Model              (InitResult (..), SignIn (..),
+                                            User (..))
 import           Common.Msg                (Key)
 import qualified Common.Msg                as Msg
 
@@ -21,26 +28,52 @@ import qualified Model.Query               as Query
 import qualified Model.SignIn              as SignIn
 import qualified Model.User                as User
 import           Secure                    (getUserFromToken)
+import qualified SendMail
+import qualified Text.Email.Validate       as Email
+import qualified View.Mail.SignIn          as SignIn
 import           View.Page                 (page)
 
-get :: Conf -> Maybe Text -> ActionM ()
-get conf mbToken = do
-  initResult <- case mbToken of
-    Just token -> do
-      userOrError <- validateSignIn conf token
-      case userOrError of
-        Left errorKey ->
-          return . InitEmpty . Left . Msg.get $ errorKey
-        Right user ->
-          liftIO . Query.run . fmap InitSuccess $ getInit user conf
-    Nothing -> do
-      mbLoggedUser <- getLoggedUser
-      case mbLoggedUser of
-        Nothing ->
-          return . InitEmpty . Right $ Nothing
-        Just user ->
-          liftIO . Query.run . fmap InitSuccess $ getInit user conf
-  html $ page initResult
+get :: Conf -> ActionM ()
+get conf = do
+  initResult <- do
+    mbLoggedUser <- getLoggedUser
+    case mbLoggedUser of
+      Nothing ->
+        return . InitEmpty . Right $ Nothing
+      Just user ->
+        liftIO . Query.run . fmap InitSuccess $ getInit user conf
+  S.html $ page initResult
+
+askSignIn :: Conf -> SignIn -> ActionM ()
+askSignIn conf (SignIn email) =
+  if Email.isValid (TE.encodeUtf8 email)
+    then do
+      maybeUser <- liftIO . Query.run $ User.get email
+      case maybeUser of
+        Just user -> do
+          token <- liftIO . Query.run $ SignIn.createSignInToken email
+          let url = T.concat [
+                      if Conf.https conf then "https://" else "http://",
+                      Conf.hostname conf,
+                      "/signIn/",
+                      token
+                    ]
+          maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
+          case maybeSentMail of
+            Right _ -> textKey ok200 Msg.SignIn_EmailSent
+            Left _  -> textKey badRequest400 Msg.SignIn_EmailSendFail
+        Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
+    else textKey badRequest400 Msg.SignIn_EmailInvalid
+  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+
+trySignIn :: Conf -> Text -> ActionM ()
+trySignIn conf token = do
+  userOrError <- validateSignIn conf token
+  case userOrError of
+    Left errorKey ->
+      S.html $ page (InitEmpty . Left . Msg.get $ errorKey)
+    Right _ ->
+      S.redirect "/"
 
 validateSignIn :: Conf -> Text -> ActionM (Either Key User)
 validateSignIn conf textToken = do
@@ -82,4 +115,4 @@ getLoggedUser = do
       liftIO . Query.run . getUserFromToken $ token
 
 signOut :: Conf -> ActionM ()
-signOut conf = LoginSession.delete conf >> status ok200
+signOut conf = LoginSession.delete conf >> S.status ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c6c874a..f2af6c9 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -22,7 +22,7 @@ import qualified Secure
 list :: ActionM ()
 list =
   Secure.loggedAction (\_ ->
-    (liftIO . Query.run $ Payment.list) >>= json
+    (liftIO . Query.run $ Payment.listActive) >>= json
   )
 
 create :: CreatePayment -> ActionM ()
diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs
deleted file mode 100644
index cf92c9f..0000000
--- a/server/src/Controller/SignIn.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Controller.SignIn
-  ( signIn
-  ) where
-
-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           Common.Model              (SignIn (..))
-import qualified Common.Msg                as Msg
-
-import           Conf                      (Conf)
-import qualified Conf
-import qualified Model.Query               as Query
-import qualified Model.SignIn              as SignIn
-import qualified Model.User                as User
-import qualified SendMail
-import qualified Text.Email.Validate       as Email
-import qualified View.Mail.SignIn          as SignIn
-
-signIn :: Conf -> SignIn -> ActionM ()
-signIn conf (SignIn email) =
-  if Email.isValid (TE.encodeUtf8 email)
-    then do
-      maybeUser <- liftIO . Query.run $ User.get email
-      case maybeUser of
-        Just user -> do
-          token <- liftIO . Query.run $ SignIn.createSignInToken email
-          let url = T.concat [
-                      if Conf.https conf then "https://" else "http://",
-                      Conf.hostname conf,
-                      "?signInToken=",
-                      token
-                    ]
-          maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email]
-          case maybeSentMail of
-            Right _ -> textKey ok200 Msg.SignIn_EmailSent
-            Left _  -> textKey badRequest400 Msg.SignIn_EmailSendFail
-        Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
-    else textKey badRequest400 Msg.SignIn_EmailInvalid
-  where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key)
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 4d4be7b..7f5f503 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -23,7 +23,7 @@ design = do
     width (pct 100)
     marginBottom (px 10)
 
-  button ? do
+  button # ".validate" ? do
     Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten
     display flex
     alignItems center
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index ca7e007..907be2b 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -12,7 +12,7 @@ import           Util.Time       (timeToDay)
 
 monthlyPayment :: Maybe UTCTime -> IO UTCTime
 monthlyPayment _ = do
-  monthlyPayments <- Query.run Payment.listMonthly
+  monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName
   now <- getCurrentTime
   actualDay <- timeToDay now
   let punctualPayments = map
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 74180df..38d88b5 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -19,10 +19,7 @@ weeklyReport conf mbLastExecution = do
     Nothing -> return ()
     Just lastExecution -> do
       (payments, incomes, users) <- Query.run $
-        (,,) <$>
-          Payment.modifiedDuring lastExecution now <*>
-          Income.modifiedDuring lastExecution now <*>
-          User.list
-      _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now)
+        (,,) <$> Payment.listPunctual <*> Income.list <*> User.list
+      _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
       return ()
   return now
diff --git a/server/src/Main.hs b/server/src/Main.hs
index c8080dc..e298a06 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,83 +1,62 @@
-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           Common.Model                  (Frequency (..), Payment (..))
-import qualified Common.Model                  as CM
+import qualified Web.Scotty                    as S
 
 import qualified Conf
 import qualified Controller.Category           as Category
 import qualified Controller.Income             as Income
 import qualified Controller.Index              as Index
 import qualified Controller.Payment            as Payment
-import qualified Controller.SignIn             as SignIn
-import qualified Data.Time                     as Time
 import           Job.Daemon                    (runDaemons)
-import qualified Model.Income                  as IncomeM
-import qualified Model.Payment                 as PaymentM
-import qualified Model.Query                   as Query
-import qualified Model.User                    as UserM
 
 main :: IO ()
 main = do
   conf <- Conf.get "application.conf"
   _ <- runDaemons conf
-  scotty (Conf.port conf) $ do
-    middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
-    middleware . staticPolicy $ noDots >-> addBase "public"
+  S.scotty (Conf.port conf) $ do
+    S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
+    S.middleware . staticPolicy $ noDots >-> addBase "public"
 
-    get "/exceedingPayer" $ do
-      time <- liftIO Time.getCurrentTime
-      (users, incomes, payments) <- liftIO . Query.run $
-        liftA3 (,,) UserM.list IncomeM.list PaymentM.list
-      let punctualPayments = filter ((==) Punctual . _payment_frequency) payments
-          exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments
-      text . LT.pack . show $ exceedingPayers
+    S.get "/" $ do
+      Index.get conf
 
-    get "/" $ do
-      signInToken <- mbParam "signInToken"
-      Index.get conf signInToken
+    S.post "/askSignIn" $ do
+      S.jsonData >>= Index.askSignIn conf
 
-    post "/signIn" $ do
-      jsonData >>= SignIn.signIn conf
+    S.get "/signIn/:signInToken" $ do
+      signInToken <- S.param "signInToken"
+      Index.trySignIn conf signInToken
 
-    post "/signOut" $
+    S.post "/signOut" $
       Index.signOut conf
 
-    post "/payment" $
-      jsonData >>= Payment.create
+    S.post "/payment" $
+      S.jsonData >>= Payment.create
 
-    put "/payment" $
-      jsonData >>= Payment.editOwn
+    S.put "/payment" $
+      S.jsonData >>= Payment.editOwn
 
-    delete "/payment" $ do
-      paymentId <- param "id"
+    S.delete "/payment" $ do
+      paymentId <- S.param "id"
       Payment.deleteOwn paymentId
 
-    post "/income" $
-      jsonData >>= Income.create
+    S.post "/income" $
+      S.jsonData >>= Income.create
 
-    put "/income" $
-      jsonData >>= Income.editOwn
+    S.put "/income" $
+      S.jsonData >>= Income.editOwn
 
-    delete "/income" $ do
-      incomeId <- param "id"
+    S.delete "/income" $ do
+      incomeId <- S.param "id"
       Income.deleteOwn incomeId
 
-    post "/category" $
-      jsonData >>= Category.create
+    S.post "/category" $
+      S.jsonData >>= Category.create
 
-    put "/category" $
-      jsonData >>= Category.edit
+    S.put "/category" $
+      S.jsonData >>= Category.edit
 
-    delete "/category" $ do
-      categoryId <- param "id"
+    S.delete "/category" $ do
+      categoryId <- S.param "id"
       Category.delete categoryId
-
-mbParam :: Parsable a => LT.Text -> ActionM (Maybe a)
-mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing)
diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs
index a6174bc..4938e50 100644
--- a/server/src/Model/Income.hs
+++ b/server/src/Model/Income.hs
@@ -5,12 +5,11 @@ module Model.Income
   , create
   , editOwn
   , deleteOwn
-  , modifiedDuring
   ) where
 
 import           Data.Maybe             (listToMaybe)
 import           Data.Time.Calendar     (Day)
-import           Data.Time.Clock        (UTCTime, getCurrentTime)
+import           Data.Time.Clock        (getCurrentTime)
 import           Database.SQLite.Simple (FromRow (fromRow), Only (Only))
 import qualified Database.SQLite.Simple as SQLite
 import           Prelude                hiding (id)
@@ -87,12 +86,3 @@ deleteOwn user incomeId =
       Nothing ->
         return False
   )
-
-modifiedDuring :: UTCTime -> UTCTime -> Query [Income]
-modifiedDuring start end =
-  Query (\conn ->
-    SQLite.query
-      conn
-      "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)"
-      (start, end, start, end, start, end)
-  )
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
index be44c72..0a0ffc7 100644
--- a/server/src/Model/Init.hs
+++ b/server/src/Model/Init.hs
@@ -18,7 +18,7 @@ getInit user conf =
   Init <$>
     User.list <*>
     (return . _user_id $ user) <*>
-    Payment.list <*>
+    Payment.listActive <*>
     Income.list <*>
     Category.list <*>
     PaymentCategory.list <*>
diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs
index a19f9ae..780efcc 100644
--- a/server/src/Model/Mail.hs
+++ b/server/src/Model/Mail.hs
@@ -5,8 +5,8 @@ module Model.Mail
 import           Data.Text (Text)
 
 data Mail = Mail
-  { from      :: Text
-  , to        :: [Text]
-  , subject   :: Text
-  , plainBody :: Text
+  { from    :: Text
+  , to      :: [Text]
+  , subject :: Text
+  , body    :: Text
   } deriving (Eq, Show)
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
index 33551e5..5b29409 100644
--- a/server/src/Model/Payment.hs
+++ b/server/src/Model/Payment.hs
@@ -3,19 +3,18 @@
 module Model.Payment
   ( Payment(..)
   , find
-  , list
-  , listMonthly
+  , listActive
+  , listPunctual
+  , listActiveMonthlyOrderedByName
   , create
   , createMany
   , editOwn
   , deleteOwn
-  , modifiedDuring
   ) where
 
 import           Data.Maybe                     (listToMaybe)
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
-import           Data.Time                      (UTCTime)
 import           Data.Time.Calendar             (Day)
 import           Data.Time.Clock                (getCurrentTime)
 import           Database.SQLite.Simple         (FromRow (fromRow), Only (Only),
@@ -66,14 +65,22 @@ find paymentId =
     SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
   )
 
-list :: Query [Payment]
-list =
+listActive :: Query [Payment]
+listActive =
   Query (\conn ->
     SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
   )
 
-listMonthly :: Query [Payment]
-listMonthly =
+listPunctual :: Query [Payment]
+listPunctual =
+  Query (\conn ->
+    SQLite.query
+      conn
+      (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
+      (Only Punctual))
+
+listActiveMonthlyOrderedByName :: Query [Payment]
+listActiveMonthlyOrderedByName =
   Query (\conn ->
     SQLite.query
       conn
@@ -83,8 +90,7 @@ listMonthly =
         , "WHERE deleted_at IS NULL AND frequency = ?"
         , "ORDER BY name DESC"
         ])
-      (Only Monthly)
-  )
+      (Only Monthly))
 
 create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
 create userId paymentName paymentCost paymentDate paymentFrequency =
@@ -161,18 +167,3 @@ deleteOwn userId paymentId =
       Nothing ->
         return False
   )
-
-modifiedDuring :: UTCTime -> UTCTime -> Query [Payment]
-modifiedDuring start end =
-  Query (\conn ->
-    SQLite.query
-      conn
-      (SQLite.Query $ T.intercalate " "
-        [ "SELECT *"
-        , "FROM payment"
-        , "WHERE (created_at >= ? AND created_at <= ?)"
-        , "   OR (edited_at >= ?  AND edited_at <= ?)"
-        , "   OR (deleted_at >= ? AND deleted_at <= ?)"
-        ])
-      (start, end, start, end, start, end)
-  )
diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs
index c15ed62..3b17a0a 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -9,18 +9,41 @@ import qualified Network.Mail.Mime      as M
 
 import           Data.Text              (Text)
 import qualified Data.Text              as T
+import qualified Data.Text.IO           as T
 import qualified Data.Text.Lazy         as LT
 import           Data.Text.Lazy.Builder (fromText, toLazyText)
 
-import           Model.Mail             (Mail (Mail))
+import           Conf                   (Conf)
+import qualified Conf
+import           Model.Mail             (Mail (..))
 
-sendMail :: Mail -> IO (Either Text ())
-sendMail mail = do
-  result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ()))
-  if isLeft result
-    then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result))
-    else putStrLn "OK"
-  return result
+sendMail :: Conf -> Mail -> IO (Either Text ())
+sendMail conf mail =
+  if Conf.devMode conf
+    then
+      do
+        T.putStrLn . mockMailMessage $ mail
+        return (Right ())
+    else
+      do
+        result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ()))
+        if isLeft result
+          then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result))
+          else return ()
+        return result
+
+mockMailMessage :: Mail -> Text
+mockMailMessage mail = T.concat $
+  [ "[MOCK MAIL] "
+  , subject mail
+  , " (from: "
+  , from mail
+  , ") (to: "
+  , T.intercalate ", " $ to mail
+  , ")"
+  , "\n"
+  , body mail
+  ]
 
 getMimeMail :: Mail -> M.Mail
 getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) =
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
index 22c3cb0..3c5469f 100644
--- a/server/src/View/Mail/SignIn.hs
+++ b/server/src/View/Mail/SignIn.hs
@@ -17,5 +17,5 @@ mail conf user url to =
     { M.from = Conf.noReplyMail conf
     , M.to = to
     , M.subject = Msg.get Msg.SignIn_MailTitle
-    , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
+    , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
     }
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 4ad8b77..5418880 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -11,8 +11,8 @@ import           Data.Text          (Text)
 import qualified Data.Text          as T
 import           Data.Time.Clock    (UTCTime)
 
-import           Common.Model       (Income (..), Payment (..), User (..),
-                                     UserId)
+import           Common.Model       (ExceedingPayer (..), Income (..),
+                                     Payment (..), User (..), UserId)
 import qualified Common.Model       as CM
 import qualified Common.Msg         as Msg
 import qualified Common.View.Format as Format
@@ -35,11 +35,31 @@ mail conf users payments incomes start end =
         , " − "
         , Msg.get Msg.WeeklyReport_Title
         ]
-    , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+    , M.body = body conf users payments incomes start end
     }
 
-body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
-body conf users paymentsByStatus incomesByStatus =
+body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
+body conf users payments incomes start end =
+  T.intercalate "\n" $
+    [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
+    , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+    ]
+
+exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
+exceedingPayers conf time users incomes payments =
+  T.intercalate "\n" . map formatPayer $ payers
+  where
+    payers = CM.getExceedingPayers time users incomes payments
+    formatPayer p = T.concat
+      [ "  * "
+      , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users
+      , " + "
+      , Format.price (Conf.currency conf) $ _exceedingPayer_amount p
+      , "\n"
+      ]
+
+operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
+operations conf users paymentsByStatus incomesByStatus =
   if M.null paymentsByStatus && M.null incomesByStatus
     then
       Msg.get Msg.WeeklyReport_Empty
@@ -96,5 +116,5 @@ section title items =
   T.concat
     [ title
     , "\n\n"
-    , T.unlines . map ("  - " <>) $ items
+    , T.unlines . map ("  * " <>) $ items
     ]
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index 27b4f26..97b84fa 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -26,10 +26,10 @@ page initResult =
       meta ! charset "UTF-8"
       meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0"
       H.title (toHtml $ Msg.get Msg.App_Title)
-      script ! src "javascript/main.js" $ ""
+      script ! src "/javascript/main.js" $ ""
       jsonScript "init" initResult
-      link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
-      link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
+      link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
+      link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png"
       H.style $ toHtml globalDesign
 
 jsonScript :: Json.ToJSON a => Text -> a -> Html
diff --git a/stylish-haskell/default.nix b/stylish-haskell/default.nix
deleted file mode 100644
index bd73cf8..0000000
--- a/stylish-haskell/default.nix
+++ /dev/null
@@ -1,44 +0,0 @@
-{ 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;
-    }
diff --git a/tools.nix b/tools.nix
index f09ad13..8c7d91f 100644
--- a/tools.nix
+++ b/tools.nix
@@ -7,11 +7,12 @@ with import <nixpkgs> {}; {
       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;
-      })
+      stylish-haskell
+      # (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;
+      # })
     ];
   };
 }
-- 
cgit v1.2.3