Sign in with email and password

9 files changed, 145 insertions, 199 deletions

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