From 0d589e12a0c32936303de46b1e462dd19648170d Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Sun, 19 Jul 2015 16:07:15 +0200
Subject: Login with a token validation

---
 src/client/Model/View.elm        |  3 ++-
 src/client/Model/View/SignIn.elm | 15 ++++++++++++++
 src/client/Update.elm            | 15 ++++++++++----
 src/client/Update/SignIn.elm     | 15 ++++++++++++++
 src/client/View/Page.elm         | 22 ++++++++++++++------
 src/server/Application.hs        | 43 +++++++++++++++++++++++++++-------------
 src/server/Design/Color.hs       |  3 +++
 src/server/Design/Global.hs      | 22 ++++++++++++--------
 src/server/Main.hs               | 10 +++++++---
 src/server/Model/Database.hs     |  7 +++++++
 src/server/Model/Message.hs      | 15 ++++++++++++++
 src/server/Model/Payment.hs      |  6 +++---
 src/server/Model/SignIn.hs       | 34 +++++++++++++++++++++++++++++++
 src/server/Model/UUID.hs         | 10 ++++++++++
 src/server/Model/User.hs         |  6 +++---
 15 files changed, 184 insertions(+), 42 deletions(-)
 create mode 100644 src/client/Model/View/SignIn.elm
 create mode 100644 src/client/Update/SignIn.elm
 create mode 100644 src/server/Model/Message.hs
 create mode 100644 src/server/Model/SignIn.hs
 create mode 100644 src/server/Model/UUID.hs

(limited to 'src')

diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm
index ca819e3..3e3cbca 100644
--- a/src/client/Model/View.elm
+++ b/src/client/Model/View.elm
@@ -3,8 +3,9 @@ module Model.View
   ) where
 
 import Model.Payment exposing (Payments)
+import Model.View.SignIn exposing (..)
 
 type View =
   LoadingView
   | PaymentView Payments
-  | SignInView String
+  | SignInView SignIn
diff --git a/src/client/Model/View/SignIn.elm b/src/client/Model/View/SignIn.elm
new file mode 100644
index 0000000..1c8eae7
--- /dev/null
+++ b/src/client/Model/View/SignIn.elm
@@ -0,0 +1,15 @@
+module Model.View.SignIn
+  ( SignIn
+  , initSignIn
+  ) where
+
+type alias SignIn =
+  { login : String
+  , authentication : Maybe (Result String String)
+  }
+
+initSignIn : SignIn
+initSignIn =
+  { login = ""
+  , authentication = Nothing
+  }
diff --git a/src/client/Update.elm b/src/client/Update.elm
index 3937888..1d0fe95 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -7,11 +7,14 @@ module Update
 import Model exposing (Model)
 import Model.Payment exposing (Payments)
 import Model.View exposing (..)
+import Model.View.SignIn exposing (..)
+
+import Update.SignIn exposing (..)
 
 type Action =
   NoOp
   | SignIn
-  | UpdateLogin String
+  | UpdateSignIn SignInAction
   | UpdatePayments Payments
 
 actions : Signal.Mailbox Action
@@ -23,8 +26,12 @@ updateModel action model =
     NoOp ->
       model
     SignIn ->
-      { model | view <- SignInView "" }
-    UpdateLogin login ->
-      { model | view <- SignInView login }
+      { model | view <- SignInView initSignIn }
+    UpdateSignIn signInAction ->
+      case model.view of
+        SignInView signIn ->
+          { model | view <- SignInView (updateSignIn signInAction signIn) }
+        _ ->
+          model
     UpdatePayments payments ->
       { model | view <- PaymentView payments }
diff --git a/src/client/Update/SignIn.elm b/src/client/Update/SignIn.elm
new file mode 100644
index 0000000..a962f90
--- /dev/null
+++ b/src/client/Update/SignIn.elm
@@ -0,0 +1,15 @@
+module Update.SignIn
+  ( SignInAction(..)
+  , updateSignIn
+  ) where
+
+import Model.View.SignIn exposing (..)
+
+type SignInAction =
+  UpdateLogin String
+
+updateSignIn : SignInAction -> SignIn -> SignIn
+updateSignIn action signIn =
+  case action of
+    UpdateLogin login ->
+      { signIn | login <- login }
diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm
index 1683cf3..eb86132 100644
--- a/src/client/View/Page.elm
+++ b/src/client/View/Page.elm
@@ -13,11 +13,14 @@ import Date exposing (Date)
 
 import String exposing (append)
 
+import Json.Decode as Json
+
 import Model exposing (Model)
 import Model.Payment exposing (Payments, Payment)
 import Model.View exposing (..)
 
 import Update exposing (..)
+import Update.SignIn exposing (..)
 
 import ServerCommunication as SC
 import ServerCommunication exposing (serverCommunications)
@@ -38,7 +41,7 @@ renderHeader model =
     []
     [ h1
         []
-        [ text "Payments" ]
+        [ text "Shared Cost" ]
     , case model.view of
         LoadingView ->
           text ""
@@ -57,7 +60,7 @@ renderMain model =
   case model.view of
     LoadingView ->
       loadingView
-    SignInView login ->
+    SignInView { login } ->
       signInView login
     PaymentView payments ->
       paymentsView payments
@@ -67,18 +70,25 @@ loadingView = text ""
 
 signInView : String -> Html
 signInView login =
-  H.form
+  div
     [ class "signIn" ]
     [ input
         [ value login
-        , on "input" targetValue (Signal.message actions.address << UpdateLogin)
+        , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
+        , onEnter serverCommunications.address (SC.SignIn login)
         ]
         []
     , button
         [ onClick serverCommunications.address (SC.SignIn login) ]
-        [ renderIcon "sign-in" ]
+        [ text "Sign in" ]
     ]
 
+onEnter : Signal.Address a -> a -> Attribute
+onEnter address value =
+  on "keydown"
+    (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err ""))
+    (\_ -> Signal.message address value)
+
 paymentsView : Payments -> Html
 paymentsView payments =
   table
@@ -112,5 +122,5 @@ paymentLine payment =
 renderDate : Date -> String
 renderDate date =
   toString (Date.day date)
-    |> flip append (" " ++ (toString (Date.month date)))
+    |> flip append (" " ++ (toString (Date.month date)) ++ ".")
     |> flip append (" " ++ (toString (Date.year date)))
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
 
-- 
cgit v1.2.3