Sign in with email and password

27 files changed, 296 insertions, 418 deletions

diff --git a/README.md b/README.md
index 2037cae..8c736d4 100644
--- a/README.md
+++ b/README.md
@@ -25,14 +25,16 @@ Init the database with migration scripts:
 
 ```bash
 sqlite3 database < server/migrations/1.sql
+sqlite3 database < server/migrations/2.sql
+sqlite3 database < server/migrations/3.sql
 ```
 
 Inside the tmux session, add some users with sqlite after the migration is done:
 
 ```
 sqlite3 database
-insert into user(creation, email, name) values (datetime('now'), 'john@mail.com', 'John');
-insert into user(creation, email, name) values (datetime('now'), 'lisa@mail.com', 'Lisa');
+insert into user(creation, email, name, password) values (datetime('now'), 'john@mail.com', 'John', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.');
+insert into user(creation, email, name, password) values (datetime('now'), 'lisa@mail.com', 'Lisa', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.');
 ```
 
 Later, stop the environment with:
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 6faecef..153a61b 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -22,7 +22,7 @@ data In t m = In
   , _in_submit   :: Bool
   }
 
-defaultIn :: MonadWidget t m => m () -> In t m
+defaultIn :: forall t m. MonadWidget t m => m () -> In t m
 defaultIn content = In
   { _in_class    = R.constDyn ""
   , _in_content  = content
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d6f89cd..c71b0f0 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -14,7 +14,7 @@ import           JSDOM.Types                          (HTMLElement (..), JSM,
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import           Common.Model                         (InitResult (InitError))
+import           Common.Model                         (Init)
 import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
@@ -24,7 +24,7 @@ main = do
   initResult <- readInit
   App.widget initResult
 
-readInit :: JSM InitResult
+readInit :: JSM (Maybe Init)
 readInit = do
   document <- Dom.currentDocumentUnchecked
   initNode <- Dom.getElementById document ("init" :: JSString)
@@ -34,8 +34,6 @@ 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   -> Nothing
     _ ->
-      return initParseError
-
-  where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
+      return Nothing
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index f9545a4..50f2468 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -3,7 +3,6 @@ module Util.Validation
   , toMaybe
   , maybeError
   , fireValidation
-  , fireMaybe
   ) where
 
 import           Control.Monad      (join)
@@ -35,13 +34,3 @@ fireValidation value validate =
   R.fmapMaybe
     (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
-
-fireMaybe
-  :: forall t a b. Reflex t
-  => Dynamic t (Maybe a)
-  -> Event t b
-  -> Event t a
-fireMaybe value validate =
-  R.fmapMaybe
-    id
-    (R.tag (R.current value) validate)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 460d499..b0b89fb 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -4,14 +4,14 @@ module View.App
 
 import qualified Data.Text              as T
 import           Prelude                hiding (error, init)
-import           Reflex.Dom             (Dynamic, MonadWidget)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, Init (..), InitResult (..),
-                                         UserId)
+import           Common.Model           (Currency, Init (..), UserId)
 import qualified Common.Msg             as Msg
 
 import           Model.Route            (Route (..))
+import qualified Util.Reflex            as ReflexUtil
 import qualified Util.Router            as Router
 import qualified View.Category.Category as Category
 import qualified View.Header            as Header
@@ -20,43 +20,40 @@ import qualified View.NotFound          as NotFound
 import qualified View.Payment.Payment   as Payment
 import qualified View.SignIn            as SignIn
 
-widget :: InitResult -> IO ()
-widget initResult =
+widget :: Maybe Init -> IO ()
+widget init =
   R.mainWidget $ R.divClass "app" $ do
 
     route <- getRoute
 
-    header <- Header.view $ Header.In
-      { Header._in_initResult = initResult
-      , Header._in_isInitSuccess =
-        case initResult of
-          InitSuccess _ -> True
-          _             -> False
-      , Header._in_route = route
-      }
-
-    let signOut =
-          Header._out_signOut header
-
-        mainContent =
-          case initResult of
-            InitSuccess init ->
-              signedWidget init route
-
-            InitEmpty ->
-              SignIn.view SignIn.EmptyMessage
+    rec
+      header <- Header.view $ Header.In
+        { Header._in_init = initState
+        , Header._in_route = route
+        }
 
-            InitError error ->
-              SignIn.view (SignIn.ErrorMessage error)
+      initState <-
+        R.foldDyn
+          const
+          init
+          (R.leftmost $
+            [ initEvent
+            , Nothing <$ (Header._out_signOut header)
+            ])
 
-        signOutContent =
-          SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+      initEvent <-
+        (R.dyn . R.ffor initState $ \case
+          Nothing -> do
+            signIn <- SignIn.view
+            return (Just <$> SignIn._out_success signIn)
 
-    _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
+          Just i -> do
+            signedWidget i route
+            return R.never) >>= ReflexUtil.flatten
 
-    R.blank
+    return ()
 
-signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute ->
@@ -85,7 +82,7 @@ signedWidget init route = do
 
   return ()
 
-getRoute :: MonadWidget t m => m (Dynamic t Route)
+getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route)
 getRoute = do
   r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never
   return . R.ffor r $ \case
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 5910f52..f91c408 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -6,6 +6,7 @@ module View.Header
 
 import           Data.Map         (Map)
 import qualified Data.Map         as M
+import qualified Data.Maybe       as Maybe
 import           Data.Text        (Text)
 import qualified Data.Text        as T
 import           Data.Time        (NominalDiffTime)
@@ -13,7 +14,7 @@ import           Prelude          hiding (error, init)
 import           Reflex.Dom       (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom       as R
 
-import           Common.Model     (Init (..), InitResult (..), User (..))
+import           Common.Model     (Init (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
 import qualified Component.Button as Button
@@ -24,9 +25,8 @@ import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
 data In t = In
-  { _in_initResult    :: InitResult
-  , _in_isInitSuccess :: Bool
-  , _in_route         :: Dynamic t Route
+  { _in_init  :: Dynamic t (Maybe Init)
+  , _in_route :: Dynamic t Route
   }
 
 data Out t = Out
@@ -40,12 +40,11 @@ view input =
     R.divClass "title" $
       R.text $ Msg.get Msg.App_Title
 
+    let showLinks = Maybe.isJust <$> _in_init input
+
     signOut <- R.el "div" $ do
-      rec
-        showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
-        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
-        signOut <- nameSignOut $ _in_initResult input
-      return signOut
+      ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
+      (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten
 
     return $ Out
       { _out_signOut = signOut
@@ -76,23 +75,24 @@ links route = do
           , ("current", linkRoute == currentRoute)
           ]
 
-nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
-nameSignOut initResult = case initResult of
-  InitSuccess init -> do
-    rec
-      attr <- R.holdDyn
-        (M.singleton "class" "nameSignOut")
-        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
-
-      signOut <- R.elDynAttr "nameSignOut" attr $ do
-        case CM.findUser (_init_currentUser init) (_init_users init) of
-          Just user -> R.divClass "name" $ R.text (_user_name user)
-          Nothing   -> R.blank
-        signOutButton
-
-    return signOut
-  _ ->
-    return R.never
+nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ())
+nameSignOut init =
+  case init of
+    Just init -> do
+      rec
+        attr <- R.holdDyn
+          (M.singleton "class" "nameSignOut")
+          (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+        signOut <- R.elDynAttr "nameSignOut" attr $ do
+          case CM.findUser (_init_currentUser init) (_init_users init) of
+            Just user -> R.divClass "name" $ R.text (_user_name user)
+            Nothing   -> R.blank
+          signOutButton
+
+      return signOut
+    _ ->
+      return R.never
 
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 0a3b576..e68755f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,17 +1,16 @@
 module View.SignIn
-  ( SignInMessage (..)
-  , view
+  ( view
+  , Out(..)
   ) where
 
 import qualified Data.Either              as Either
 import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
-import           Data.Validation          (Validation)
-import           Prelude                  hiding (error)
+import qualified Data.Validation          as V
 import           Reflex.Dom               (Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
-import           Common.Model             (SignInForm (SignInForm))
+import           Common.Model             (Init, SignInForm (SignInForm))
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.SignIn as SignInValidation
 
@@ -22,22 +21,32 @@ import qualified Util.Ajax                as Ajax
 import qualified Util.Validation          as ValidationUtil
 import qualified Util.WaitFor             as WaitFor
 
-data SignInMessage =
-  SuccessMessage Text
-  | ErrorMessage Text
-  | EmptyMessage
+data Out t = Out
+  { _out_success       :: Event t Init
+  }
 
-view :: forall t m. MonadWidget t m => SignInMessage -> m ()
-view signInMessage =
-  R.divClass "signIn" $
+view :: forall t m. MonadWidget t m => m (Out t)
+view = do
+  signInResult <- R.divClass "signIn" $
     Form.view $ do
       rec
-        input <- (Input.view
+        let resetForm = ("" <$ R.ffilter Either.isRight signInResult)
+
+        email <- Input._out_raw <$> (Input.view
           (Input.defaultIn
             { Input._in_label = Msg.get Msg.SignIn_EmailLabel
             , Input._in_validation = SignInValidation.email
             })
-          ("" <$ R.ffilter Either.isRight signInResult)
+          resetForm
+          validate)
+
+        password <- Input._out_raw <$> (Input.view
+          (Input.defaultIn
+            { Input._in_label = Msg.get Msg.SignIn_PasswordLabel
+            , Input._in_validation = SignInValidation.password
+            , Input._in_inputType = "password"
+            })
+          resetForm
           validate)
 
         validate <- Button._out_clic <$> (Button.view $
@@ -47,27 +56,27 @@ view signInMessage =
             , Button._in_submit = True
             })
 
-        let form = SignInForm <$> Input._out_raw input
+        let form = do
+              e <- email
+              p <- password
+              return . V.Success $ SignInForm e p
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postAndParseResult "/api/askSignIn")
-          (ValidationUtil.fireMaybe
-            ((\f -> f <$ SignInValidation.signIn f) <$> form)
-            validate)
+          (Ajax.postAndParseResult "/api/signIn")
+          (ValidationUtil.fireValidation form validate)
 
-      showSignInResult signInMessage signInResult
+      showSignInResult signInResult
 
-showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
-showSignInResult signInMessage signInResult = do
-  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
-  R.blank
+      return signInResult
 
-  where showInitResult (SuccessMessage success) = showSuccess success
-        showInitResult (ErrorMessage error)     = showError error
-        showInitResult EmptyMessage             = R.blank
+  return $ Out
+    { _out_success = R.filterRight signInResult
+    }
 
-        showResult (Left error)    = showError error
-        showResult (Right success) = showSuccess success
+showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m ()
+showSignInResult signInResult = do
+  _ <- R.widgetHold R.blank $ showResult <$> signInResult
+  R.blank
 
-        showError = R.divClass "error" . R.text
-        showSuccess = R.divClass "success" . R.text
+  where showResult (Left error) = R.divClass "error" . R.text $ error
+        showResult (Right _)    = R.blank
diff --git a/common/common.cabal b/common/common.cabal
index fdede8f..d09e29b 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -35,6 +35,7 @@ Library
     Common.Model.CreateIncomeForm
     Common.Model.CreatePaymentForm
     Common.Model.Email
+    Common.Model.Password
     Common.Model.Payment
     Common.Model.SignInForm
     Common.Model.User
@@ -66,6 +67,5 @@ Library
     Common.Model.IncomeHeader
     Common.Model.IncomePage
     Common.Model.Init
-    Common.Model.InitResult
     Common.Model.PaymentHeader
     Common.Model.PaymentPage
diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs
index 2561156..b778a8f 100644
--- a/common/src/Common/Message/Key.hs
+++ b/common/src/Common/Message/Key.hs
@@ -118,16 +118,9 @@ data Key =
 
   | SignIn_Button
   | SignIn_DisconnectSuccess
-  | SignIn_EmailInvalid
+  | SignIn_InvalidCredentials
   | SignIn_EmailLabel
-  | SignIn_EmailSendFail
-  | SignIn_EmailSent
-  | SignIn_LinkExpired
-  | SignIn_LinkInvalid
-  | SignIn_LinkUsed
-  | SignIn_MailTitle
-  | SignIn_MailBody Text Text
-  | SignIn_ParseError
+  | SignIn_PasswordLabel
 
   | Statistic_Title
   | Statistic_ByMonthsAndMean Text
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index a86a371..e74c801 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -517,80 +517,20 @@ m l SignIn_DisconnectSuccess =
     English -> "You have successfully disconnected"
     French  -> "Vous êtes à présent déconnecté."
 
-m l SignIn_EmailInvalid =
+m l SignIn_InvalidCredentials =
   case l of
-    English -> "Your email is not valid."
-    French  -> "Votre courriel n’est pas valide."
+    English -> "Your credentials are not valid."
+    French  -> "Vos identifiants de connexion ne sont pas valides."
 
 m l SignIn_EmailLabel =
   case l of
     English -> "Email"
     French  -> "Courriel"
 
-m l SignIn_EmailSendFail =
-  case l of
-    English -> "You are authorized to sign in, but we failed to send you the sign up email."
-    French  -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion."
-
-m l SignIn_EmailSent =
-  case l of
-    English -> "We sent you an email with a connexion link."
-    French  -> "Nous t’avons envoyé un courriel avec un lien pour te connecter."
-
-m l SignIn_LinkExpired =
-  case l of
-    English -> "The link expired, please sign in again."
-    French  -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau."
-
-m l SignIn_LinkInvalid =
-  case l of
-    English -> "The link is invalid, please sign in again."
-    French  -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau."
-
-m l SignIn_LinkUsed =
-  case l of
-    English -> "You already used this link, please sign in again."
-    French  -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau."
-
-m l SignIn_MailTitle =
-  case l of
-    English -> T.concat [ "Sign in to ", m l App_Title ]
-    French  -> T.concat [ "Connexion à ", m l App_Title ]
-
-m l (SignIn_MailBody name url) =
-  T.intercalate
-    "\n"
-    ( case l of
-        English ->
-          [ T.concat [ "Hi ", name, "," ]
-          , ""
-          , T.concat
-              [ "Click to the following link in order to sign in to Shared Cost:"
-              , m l App_Title
-              , ":"
-              ]
-          , url
-          , ""
-          , "See you soon!"
-          ]
-        French  ->
-          [ T.concat [ "Salut ", name, "," ]
-          , ""
-          , T.concat
-              [ "Clique sur le lien suivant pour te connecter à "
-              , m l App_Title
-              , ":"
-              ]
-          , url
-          , ""
-          , "À très vite !"
-          ]
-    )
-
-m l SignIn_ParseError =
-  case l of
-    English -> "Error while reading initial data."
-    French  -> "Erreur lors de la lecture des données initiales."
+m l SignIn_PasswordLabel =
+  case l of
+    English -> "Password"
+    French  -> "Mot de passe"
 
 m l (Statistic_ByMonthsAndMean amount) =
   case l of
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index 73cbf6c..c11d6ef 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -17,7 +17,7 @@ import           Common.Model.Income             as X
 import           Common.Model.IncomeHeader       as X
 import           Common.Model.IncomePage         as X
 import           Common.Model.Init               as X
-import           Common.Model.InitResult         as X
+import           Common.Model.Password           as X
 import           Common.Model.Payment            as X
 import           Common.Model.PaymentHeader      as X
 import           Common.Model.PaymentPage        as X
diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs
deleted file mode 100644
index f4c08a9..0000000
--- a/common/src/Common/Model/InitResult.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Common.Model.InitResult
-  ( InitResult(..)
-  ) where
-
-import           Data.Aeson        (FromJSON, ToJSON)
-import           Data.Text         (Text)
-import           GHC.Generics      (Generic)
-
-import           Common.Model.Init (Init)
-
-data InitResult =
-  InitSuccess Init
-  | InitError Text
-  | InitEmpty
-  deriving (Show, Generic)
-
-instance FromJSON InitResult
-instance ToJSON InitResult
diff --git a/common/src/Common/Model/Password.hs b/common/src/Common/Model/Password.hs
new file mode 100644
index 0000000..1b51a47
--- /dev/null
+++ b/common/src/Common/Model/Password.hs
@@ -0,0 +1,12 @@
+module Common.Model.Password
+  ( Password(..)
+  ) where
+
+import           Data.Aeson   (FromJSON, ToJSON)
+import           Data.Text    (Text)
+import           GHC.Generics (Generic)
+
+newtype Password = Password Text deriving (Show, Generic)
+
+instance FromJSON Password
+instance ToJSON Password
diff --git a/common/src/Common/Model/SignInForm.hs b/common/src/Common/Model/SignInForm.hs
index 2b8c955..7a25935 100644
--- a/common/src/Common/Model/SignInForm.hs
+++ b/common/src/Common/Model/SignInForm.hs
@@ -7,7 +7,8 @@ import           Data.Text    (Text)
 import           GHC.Generics (Generic)
 
 data SignInForm = SignInForm
-  { _signIn_email :: Text
+  { _signInForm_email    :: Text
+  , _signInForm_password :: Text
   } deriving (Show, Generic)
 
 instance FromJSON SignInForm
diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs
index 4bb7cad..9c21e14 100644
--- a/common/src/Common/Validation/Atomic.hs
+++ b/common/src/Common/Validation/Atomic.hs
@@ -1,10 +1,11 @@
 module Common.Validation.Atomic
-  ( nonEmpty
+  ( color
+  , day
   , minLength
-  , number
+  , nonEmpty
   , nonNullNumber
-  , day
-  , color
+  , number
+  , password
   ) where
 
 import qualified Data.Char          as Char
@@ -55,3 +56,6 @@ color str =
 
   else
     V.Failure (Msg.get Msg.Form_InvalidColor)
+
+password :: Text -> Validation Text Text
+password = minLength 8
diff --git a/common/src/Common/Validation/SignIn.hs b/common/src/Common/Validation/SignIn.hs
index 18ceb44..ac9cc37 100644
--- a/common/src/Common/Validation/SignIn.hs
+++ b/common/src/Common/Validation/SignIn.hs
@@ -1,19 +1,17 @@
 module Common.Validation.SignIn
-  ( signIn
-  , email
+  ( email
+  , password
   ) where
 
 import           Data.Text                (Text)
 import           Data.Validation          (Validation)
 
 import           Common.Model.Email       (Email (..))
-import           Common.Model.SignInForm  (SignInForm (..))
+import           Common.Model.Password    (Password (..))
 import qualified Common.Validation.Atomic as Atomic
-import qualified Data.Validation          as Validation
-
-signIn :: SignInForm -> Maybe Email
-signIn (SignInForm str) =
-  Validation.validation (const Nothing) Just . email $ str
 
 email :: Text -> Validation Text Email
 email = fmap Email . Atomic.minLength 5
+
+password :: Text -> Validation Text Password
+password = fmap Password . Atomic.minLength 8
diff --git a/server/migrations/3.sql b/server/migrations/3.sql
new file mode 100644
index 0000000..a3d8a13
--- /dev/null
+++ b/server/migrations/3.sql
@@ -0,0 +1,5 @@
+DROP TABLE sign_in;
+
+ALTER TABLE user ADD COLUMN "password" TEXT NOT NULL DEFAULT "password";
+
+ALTER TABLE user ADD COLUMN "sign_in_token" TEXT NULL;
diff --git a/server/server.cabal b/server/server.cabal
index d38949d..7ef5328 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -25,6 +25,7 @@ Executable server
       aeson
     , base >= 4.11 && < 5
     , base64-bytestring
+    , bcrypt
     , blaze-builder
     , blaze-html
     , bytestring
@@ -101,6 +102,7 @@ Executable server
     Model.EditCategory
     Model.EditIncome
     Model.EditPayment
+    Model.HashedPassword
     Model.IncomeResource
     Model.Mail
     Model.PaymentResource
@@ -121,6 +123,6 @@ Executable server
     Validation.Category
     Validation.Income
     Validation.Payment
-    View.Mail.SignIn
+    Validation.SignIn
     View.Mail.WeeklyReport
     View.Page
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 3788685..4f4ae77 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,120 +1,76 @@
 module Controller.Index
   ( get
-  , askSignIn
-  , trySignIn
+  , signIn
   , signOut
   ) where
 
 import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.Aeson                as Json
 import           Data.Text                 (Text)
-import qualified Data.Text                 as T
 import qualified Data.Text.Lazy            as TL
-import           Data.Time.Clock           (diffUTCTime, getCurrentTime)
+import           Data.Validation           (Validation (..))
 import qualified Network.HTTP.Types.Status as Status
-import           Prelude                   hiding (error)
+import           Prelude                   hiding (error, init)
 import           Web.Scotty                (ActionM)
 import qualified Web.Scotty                as S
 
-import           Common.Model              (Email (..), Init (..),
-                                            InitResult (..), SignInForm (..),
+import           Common.Model              (Init (..), SignInForm (..),
                                             User (..))
-import           Common.Msg                (Key)
 import qualified Common.Msg                as Msg
-import qualified Common.Validation.SignIn  as SignInValidation
 
 import           Conf                      (Conf (..))
 import qualified LoginSession
+import           Model.Query               (Query)
 import qualified Model.Query               as Query
-import qualified Model.SignIn              as SignIn
+import           Model.SignIn              (SignIn (..))
 import qualified Persistence.User          as UserPersistence
-import qualified Secure
-import qualified SendMail
-import qualified View.Mail.SignIn          as SignIn
+import qualified Validation.SignIn         as SignInValidation
 import           View.Page                 (page)
 
 get :: Conf -> ActionM ()
 get conf = do
-  initResult <- do
-    mbLoggedUser <- getLoggedUser
-    case mbLoggedUser of
+  init <- do
+    mbToken <- LoginSession.get
+    case mbToken of
       Nothing ->
-        return InitEmpty
-      Just user -> do
-        users <- liftIO . Query.run $ UserPersistence.list
-        return . InitSuccess $ Init users (_user_id user) (Conf.currency conf)
-  S.html $ page initResult
+        return Nothing
+      Just token -> do
+        liftIO . Query.run $ getInit conf token
+  S.html $ page init
 
-askSignIn :: Conf -> SignInForm -> ActionM ()
-askSignIn conf form =
+signIn :: Conf -> SignInForm -> ActionM ()
+signIn conf form =
   case SignInValidation.signIn form of
-    Nothing ->
-      textKey Status.badRequest400 Msg.SignIn_EmailInvalid
-    Just (Email email) -> do
-      maybeUser <- liftIO . Query.run $ UserPersistence.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,
-                      "/api/signIn/",
-                      token
-                    ]
-          maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
-          case maybeSentMail of
-            Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
-            Left _  -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail
-        Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized
-  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+    Failure _ ->
+      textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+    Success (SignIn email password) -> do
+      result <- liftIO . Query.run $ do
+        isPasswordValid <- UserPersistence.checkPassword email password
+        if isPasswordValid then
+          do
+            signInToken <- UserPersistence.createSignInToken email
+            init <- getInit conf signInToken
+            return $ Just (signInToken, init)
+        else
+          return Nothing
+      case result of
+        Just (signInToken, init) -> do
+          LoginSession.put conf signInToken
+          S.json init
 
-trySignIn :: Conf -> Text -> ActionM ()
-trySignIn conf token = do
-  userOrError <- validateSignIn conf token
-  case userOrError of
-    Left errorKey ->
-      S.html $ page (InitError $ Msg.get errorKey)
-    Right _ ->
-      S.redirect "/"
-
-validateSignIn :: Conf -> Text -> ActionM (Either Key User)
-validateSignIn conf textToken = do
-  mbLoggedUser <- getLoggedUser
-  case mbLoggedUser of
-    Just loggedUser ->
-      return . Right $ loggedUser
-    Nothing -> do
-      mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken
-      now <- liftIO getCurrentTime
-      case mbSignIn of
         Nothing ->
-          return . Left $ Msg.SignIn_LinkInvalid
-        Just signIn ->
-          if SignIn.isUsed signIn
-            then
-              return . Left $ Msg.SignIn_LinkUsed
-            else
-              let diffTime = now `diffUTCTime` (SignIn.creation signIn)
-              in  if diffTime > signInExpiration conf
-                    then
-                      return . Left $ Msg.SignIn_LinkExpired
-                    else do
-                      LoginSession.put conf (SignIn.token signIn)
-                      mbUser <- liftIO . Query.run $ do
-                        SignIn.signInTokenToUsed . SignIn.id $ signIn
-                        UserPersistence.get . SignIn.email $ signIn
-                      return $ case mbUser of
-                        Nothing   -> Left Msg.Secure_Unauthorized
-                        Just user -> Right user
+          textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
 
-getLoggedUser :: ActionM (Maybe User)
-getLoggedUser = do
-  mbToken <- LoginSession.get
-  case mbToken of
+getInit :: Conf -> Text -> Query (Maybe Init)
+getInit conf signInToken = do
+  user <- UserPersistence.get signInToken
+  case user of
+    Just u ->
+      do
+        users <- UserPersistence.list
+        return . Just $ Init users (_user_id u) (Conf.currency conf)
     Nothing ->
       return Nothing
-    Just token -> do
-      liftIO . Query.run . Secure.getUserFromToken $ token
 
 signOut :: Conf -> ActionM ()
 signOut conf = LoginSession.delete conf >> S.status Status.ok200
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 0b80de0..324557e 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -28,12 +28,8 @@ main = do
     S.middleware . staticPolicy $
       noDots >-> addBase "public"
 
-    S.post "/api/askSignIn" $
-      S.jsonData >>= Index.askSignIn conf
-
-    S.get "/api/signIn/:signInToken" $ do
-      signInToken <- S.param "signInToken"
-      Index.trySignIn conf signInToken
+    S.post "/api/signIn" $
+      S.jsonData >>= Index.signIn conf
 
     S.post "/api/signOut" $
       Index.signOut conf
diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs
new file mode 100644
index 0000000..c71e372
--- /dev/null
+++ b/server/src/Model/HashedPassword.hs
@@ -0,0 +1,27 @@
+module Model.HashedPassword
+  ( hash
+  , check
+  , HashedPassword(..)
+  ) where
+
+import qualified Crypto.BCrypt         as BCrypt
+import           Data.Text             (Text)
+import qualified Data.Text.Encoding    as TE
+
+import           Common.Model.Password (Password (..))
+
+newtype HashedPassword = HashedPassword Text deriving (Show)
+
+hash :: Password -> IO (Maybe HashedPassword)
+hash (Password p) = do
+  hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p)
+  case hashed of
+    Nothing ->
+      return Nothing
+
+    Just h ->
+      return . Just . HashedPassword . TE.decodeUtf8 $ h
+
+check :: Password -> HashedPassword -> Bool
+check (Password p) (HashedPassword h) =
+  BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p)
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index bcdce61..a217bae 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -1,64 +1,10 @@
 module Model.SignIn
   ( SignIn(..)
-  , createSignInToken
-  , getSignIn
-  , signInTokenToUsed
-  , isLastTokenValid
   ) where
 
-import           Data.Int               (Int64)
-import qualified Data.Maybe             as Maybe
-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)
-
-type SignInId = Int64
+import           Common.Model (Email, Password)
 
 data SignIn = SignIn
-  { id       :: SignInId
-  , token    :: Text
-  , creation :: UTCTime
-  , email    :: Text
-  , isUsed   :: Bool
+  { _signIn_email    :: Email
+  , _signIn_password :: Password
   } deriving Show
-
-instance FromRow SignIn where
-  fromRow = SignIn <$>
-    SQLite.field <*>
-    SQLite.field <*>
-    SQLite.field <*>
-    SQLite.field <*>
-    SQLite.field
-
-createSignInToken :: Text -> Query Text
-createSignInToken signInEmail =
-  Query (\conn -> do
-    now <- getCurrentTime
-    signInToken <- generateUUID
-    SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False)
-    return signInToken
-  )
-
-getSignIn :: Text -> Query (Maybe SignIn)
-getSignIn signInToken =
-  Query (\conn -> do
-    Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
-  )
-
-signInTokenToUsed :: SignInId -> Query ()
-signInTokenToUsed tokenId =
-  Query (\conn ->
-    SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId)
-  )
-
-isLastTokenValid :: SignIn -> Query Bool
-isLastTokenValid signIn =
-  Query (\conn -> do
-    [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True)
-    return . maybe False (== (token signIn)) $ lastToken
-  )
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
index 89eb57d..12145ac 100644
--- a/server/src/Persistence/User.hs
+++ b/server/src/Persistence/User.hs
@@ -1,17 +1,21 @@
 module Persistence.User
   ( list
   , get
+  , checkPassword
+  , createSignInToken
   ) where
 
 import qualified Data.Maybe             as Maybe
 import           Data.Text              (Text)
 import           Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
 import qualified Database.SQLite.Simple as SQLite
-import           Prelude                hiding (id)
 
-import           Common.Model           (User (..))
+import           Common.Model           (Email (..), Password (..), User (..))
 
+import           Model.HashedPassword   (HashedPassword (..))
+import qualified Model.HashedPassword   as HashedPassword
 import           Model.Query            (Query (Query))
+import qualified Model.UUID             as UUID
 
 newtype Row = Row User
 
@@ -26,15 +30,49 @@ list :: Query [User]
 list =
   Query (\conn -> do
     map (\(Row u) -> u) <$>
-      SQLite.query_ conn "SELECT * from user ORDER BY creation DESC"
+      SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC"
   )
 
 get :: Text -> Query (Maybe User)
-get email =
+get token =
   Query (\conn -> do
     fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
       SQLite.queryNamed
         conn
-        "SELECT * FROM user WHERE email = :email LIMIT 1"
+        "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1"
+        [ ":sign_in_token" := token ]
+  )
+
+data HashedPasswordRow = HashedPasswordRow HashedPassword
+
+instance FromRow HashedPasswordRow where
+  fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field)
+
+checkPassword :: Email -> Password -> Query Bool
+checkPassword (Email email) password =
+  Query (\conn -> do
+    hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$>
+      SQLite.queryNamed
+        conn
+        "SELECT password FROM user WHERE email = :email LIMIT 1"
         [ ":email" := email ]
+    case hashedPassword of
+      Just h ->
+        return (HashedPassword.check password h)
+
+      Nothing ->
+        return False
+  )
+
+createSignInToken :: Email -> Query Text
+createSignInToken (Email email) =
+  Query (\conn -> do
+    token <- UUID.generateUUID
+    SQLite.executeNamed
+      conn
+      "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email"
+      [ ":sign_in_token" := token
+      , ":email" := email
+      ]
+    return token
   )
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index 4fb2333..a30941f 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -1,21 +1,17 @@
 module Secure
   ( loggedAction
-  , getUserFromToken
   ) where
 
 import           Control.Monad.IO.Class    (liftIO)
-import           Data.Text                 (Text)
-import           Data.Text.Lazy            (fromStrict)
-import           Network.HTTP.Types.Status (forbidden403)
+import qualified Data.Text.Lazy            as TL
+import qualified Network.HTTP.Types.Status as HTTP
 import           Web.Scotty
 
 import           Common.Model              (User)
 import qualified Common.Msg                as Msg
 
 import qualified LoginSession
-import           Model.Query               (Query)
 import qualified Model.Query               as Query
-import qualified Model.SignIn              as SignIn
 import qualified Persistence.User          as UserPersistence
 
 loggedAction :: (User -> ActionM ()) -> ActionM ()
@@ -23,22 +19,13 @@ loggedAction action = do
   maybeToken <- LoginSession.get
   case maybeToken of
     Just token -> do
-      maybeUser <- liftIO . Query.run . getUserFromToken $ token
+      maybeUser <- liftIO . Query.run . UserPersistence.get $ token
       case maybeUser of
         Just user ->
           action user
         Nothing -> do
-          status forbidden403
-          html . fromStrict . Msg.get $ Msg.Secure_Unauthorized
+          status HTTP.forbidden403
+          html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized
     Nothing -> do
-      status forbidden403
-      html . fromStrict . Msg.get $ Msg.Secure_Forbidden
-
-getUserFromToken :: Text -> Query (Maybe User)
-getUserFromToken token = do
-  mbSignIn <- SignIn.getSignIn token
-  case mbSignIn of
-    Just signIn ->
-      UserPersistence.get (SignIn.email signIn)
-    Nothing ->
-      return Nothing
+      status HTTP.forbidden403
+      html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden
diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs
new file mode 100644
index 0000000..dc86122
--- /dev/null
+++ b/server/src/Validation/SignIn.hs
@@ -0,0 +1,16 @@
+module Validation.SignIn
+  ( signIn
+  ) where
+
+import           Data.Text                (Text)
+import           Data.Validation          (Validation)
+
+import           Common.Model             (SignInForm (..))
+import qualified Common.Validation.SignIn as SignInValidation
+import           Model.SignIn             (SignIn (..))
+
+signIn :: SignInForm -> Validation Text SignIn
+signIn form =
+  SignIn
+    <$> SignInValidation.email (_signInForm_email form)
+    <*> SignInValidation.password (_signInForm_password form)
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
deleted file mode 100644
index 3c5469f..0000000
--- a/server/src/View/Mail/SignIn.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module View.Mail.SignIn
-  ( mail
-  ) where
-
-import           Data.Text    (Text)
-
-import           Common.Model (User (..))
-import qualified Common.Msg   as Msg
-
-import           Conf         (Conf)
-import qualified Conf         as Conf
-import qualified Model.Mail   as M
-
-mail :: Conf -> User -> Text -> [Text] -> M.Mail
-mail conf user url to =
-  M.Mail
-    { M.from = Conf.noReplyMail conf
-    , M.to = to
-    , M.subject = Msg.get Msg.SignIn_MailTitle
-    , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
-    }
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index f47c544..4ada5f7 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -6,6 +6,7 @@ import           Data.Aeson                    (encode)
 import qualified Data.Aeson.Types              as Json
 import           Data.Text.Internal.Lazy       (Text)
 import           Data.Text.Lazy.Encoding       (decodeUtf8)
+import           Prelude                       hiding (init)
 
 import           Text.Blaze.Html
 import           Text.Blaze.Html.Renderer.Text (renderHtml)
@@ -14,20 +15,20 @@ import qualified Text.Blaze.Html5              as H
 import           Text.Blaze.Html5.Attributes
 import qualified Text.Blaze.Html5.Attributes   as A
 
-import           Common.Model                  (InitResult)
+import           Common.Model                  (Init)
 import qualified Common.Msg                    as Msg
 
 import           Design.Global                 (globalDesign)
 
-page :: InitResult -> Text
-page initResult =
+page :: Maybe Init -> Text
+page init =
   renderHtml . docTypeHtml $ do
     H.head $ do
       meta ! charset "UTF-8"
       meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0"
       H.title (toHtml $ Msg.get Msg.App_Title)
       script ! src "/javascript/main.js" $ ""
-      jsonScript "init" initResult
+      jsonScript "init" init
       link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
       link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png"
       H.style $ toHtml globalDesign