Login with a token validation

10 files changed, 125 insertions, 31 deletions

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 28ad3cd..75d0323 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -1,14 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Application
-  ( signIn
-  , signOut
+  ( signInAction
+  , validateSignInAction
+  , signOutAction
   , getIndexAction
   , getUsersAction
   , getPaymentsAction
   , addUserAction
   , deleteUserAction
-  , insertPaymentAction
+  , createPaymentAction
   ) where
 
 import Web.Scotty
@@ -21,16 +22,17 @@ import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 import Data.String (fromString)
-import qualified Data.Text.Lazy as TL
 
 import qualified LoginSession
 
 import qualified Secure
 
-import Model.Database (runDb)
+import Model.Database
 import Model.User
 import Model.Payment
+import Model.SignIn
 
 import View.Page (page)
 
@@ -51,7 +53,7 @@ getPaymentsAction =
 
 addUserAction :: Text -> Text -> ActionM ()
 addUserAction email name = do
-  _ <- liftIO . runDb $ insertUser email name
+  _ <- liftIO . runDb $ createUser email name
   status ok200
 
 deleteUserAction :: Text -> ActionM ()
@@ -59,28 +61,41 @@ deleteUserAction email = do
   _ <- liftIO . runDb $ deleteUser email
   status ok200
 
-insertPaymentAction :: Text -> Text -> Int -> ActionM ()
-insertPaymentAction email name cost = do
+createPaymentAction :: Text -> Text -> Int -> ActionM ()
+createPaymentAction email name cost = do
   maybeUser <- liftIO . runDb $ getUser email
   case maybeUser of
     Just user -> do
-      _ <- liftIO . runDb $ insertPayment (entityKey user) name cost
+      _ <- liftIO . runDb $ createPayment (entityKey user) name cost
       return ()
     Nothing -> do
       status badRequest400
       status ok200
 
-signIn :: Text -> ActionM ()
-signIn login = do
+signInAction :: Text -> ActionM ()
+signInAction login = do
   maybeUser <- liftIO . runDb $ getUser login
   case maybeUser of
     Just _ -> do
-      LoginSession.put login
+      token <- liftIO . runDb $ createSignInToken login
+      let url = T.concat ["http://localhost:3000/validateSignIn?token=", token]
+      liftIO . TIO.putStrLn $ url
       status ok200
     Nothing ->
       status badRequest400
 
-signOut :: ActionM ()
-signOut = do
+validateSignInAction :: Text -> ActionM ()
+validateSignInAction token = do
+  maybeSignIn <- liftIO . runDb $ getSignInToken token
+  case maybeSignIn of
+    Just signIn -> do
+      LoginSession.put (signInEmail . entityVal $ signIn)
+      liftIO . runDb . signInTokenIsUsed . entityKey $ signIn
+      redirect "/"
+    Nothing ->
+      status badRequest400
+
+signOutAction :: ActionM ()
+signOutAction = do
   LoginSession.delete
   status ok200
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index 6344fe6..b744cf2 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -11,5 +11,8 @@ brown = C.brown
 green :: C.Color
 green = C.green
 
+grey :: C.Color
+grey = C.rgb 200 200 200
+
 lightGrey :: C.Color
 lightGrey = C.rgb 245 245 245
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 7074f65..6e3cbe6 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -9,7 +9,6 @@ import Prelude
 
 import Clay
 
-import Data.Monoid ((<>))
 import Data.Text.Lazy (Text)
 
 import Design.Color as C
@@ -23,8 +22,12 @@ iconFontSize = 32
 global :: Css
 global = do
 
+  input ? do
+    borderRadius (px 0) (px 0) (px 0) (px 0)
+    border solid (px 1) C.grey
+
   header ? do
-    let headerHeight = 120
+    let headerHeight = 150
 
     h1 ? do
       fontSize (px 40)
@@ -64,20 +67,23 @@ global = do
       lineHeight (px 60)
       nthChild "odd" & backgroundColor C.lightGrey
 
-  form # ".signIn" ? do
+  ".signIn" ? do
     let inputHeight = 50
-    marginTop (px 80)
-    marginBottom (px 80)
-    width (pct 60)
+    width (px 500)
+    marginTop (px 50)
     marginLeft auto
     marginRight auto
     input ? do
-      width (pct 80)
+      display block
+      width (pct 100)
       padding (px 10) (px 10) (px 10) (px 10)
       height (px inputHeight)
+      marginBottom (px 10)
     button ? do
-      width (pct 20)
+      display block
+      width (pct 100)
       height (px inputHeight)
       backgroundColor C.brown
       color C.white
       borderWidth (px 0)
+      borderRadius (px 3) (px 3) (px 3) (px 3)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 4461945..7fd42a7 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -23,10 +23,14 @@ main = do
 
     post "/signIn" $ do
       login <- param "login" :: ActionM Text
-      signIn login
+      signInAction login
+
+    get "/validateSignIn" $ do
+      token <- param "token" :: ActionM Text
+      validateSignInAction token
 
     post "/signOut" $
-      signOut
+      signOutAction
 
     get "/payments" $
       getPaymentsAction
@@ -43,4 +47,4 @@ main = do
       email <- param "email" :: ActionM Text
       name <- param "name" :: ActionM Text
       cost <- param "cost" :: ActionM Int
-      insertPaymentAction email name cost
+      createPaymentAction email name cost
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index abf235d..e5fd075 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -33,6 +33,13 @@ Payment
   name Text
   cost Int
   deriving Show
+SignIn
+  token Text
+  creation UTCTime
+  email Text
+  isUsed Bool
+  UniqToken token
+  deriving Show
 |]
 
 type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
new file mode 100644
index 0000000..acc785e
--- /dev/null
+++ b/src/server/Model/Message.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Message.Json
+  ( Message(..)
+  ) where
+
+import Data.Aeson
+import GHC.Generics
+
+data Message = Message
+  { message :: String
+  } deriving (Show, Generic)
+
+instance FromJSON Message
+instance ToJSON Message
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index b35e13c..ad1c261 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,6 +1,6 @@
 module Model.Payment
   ( getPayments
-  , insertPayment
+  , createPayment
   ) where
 
 import Data.Text (Text)
@@ -30,7 +30,7 @@ getJsonPayment (paymentEntity, userEntity) =
   in  P.Payment (paymentCreation payment) (paymentName payment) (paymentCost payment) (userName user)
 
 
-insertPayment :: UserId -> Text -> Int -> Persist PaymentId
-insertPayment userId name cost = do
+createPayment :: UserId -> Text -> Int -> Persist PaymentId
+createPayment userId name cost = do
   now <- liftIO getCurrentTime
   insert $ Payment userId now name cost
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
new file mode 100644
index 0000000..c447416
--- /dev/null
+++ b/src/server/Model/SignIn.hs
@@ -0,0 +1,34 @@
+module Model.SignIn
+  ( createSignInToken
+  , getSignInToken
+  , signInTokenIsUsed
+  ) where
+
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+
+import Control.Monad.IO.Class (liftIO)
+
+import Database.Persist
+
+import Model.Database
+import Model.UUID (generateUUID)
+
+createSignInToken :: Text -> Persist Text
+createSignInToken email = do
+  now <- liftIO getCurrentTime
+  token <- liftIO generateUUID
+  _ <- insert $ SignIn token now email False
+  return token
+
+getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
+getSignInToken token =
+  selectFirst
+    [ SignInToken ==. token
+    , SignInIsUsed ==. False
+    ]
+    []
+
+signInTokenIsUsed :: SignInId -> Persist ()
+signInTokenIsUsed tokenId =
+  update tokenId [SignInIsUsed =. True]
diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs
new file mode 100644
index 0000000..6cb7ce0
--- /dev/null
+++ b/src/server/Model/UUID.hs
@@ -0,0 +1,10 @@
+module Model.UUID
+  ( generateUUID
+  ) where
+
+import Data.UUID (toString)
+import Data.UUID.V4 (nextRandom)
+import Data.Text (Text, pack)
+
+generateUUID :: IO Text
+generateUUID = pack . toString <$> nextRandom
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
index ddca0fb..339aff6 100644
--- a/src/server/Model/User.hs
+++ b/src/server/Model/User.hs
@@ -1,7 +1,7 @@
 module Model.User
   ( getUsers
   , getUser
-  , insertUser
+  , createUser
   , deleteUser
   ) where
 
@@ -20,8 +20,8 @@ getUsers = map entityVal <$> selectList [] [Desc UserCreation]
 getUser :: Text -> Persist (Maybe (Entity User))
 getUser email = selectFirst [UserEmail ==. email] []
 
-insertUser :: Text -> Text -> Persist UserId
-insertUser email name = do
+createUser :: Text -> Text -> Persist UserId
+createUser email name = do
   now <- liftIO getCurrentTime
   insert $ User now email name