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/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 +++---
 6 files changed, 72 insertions(+), 6 deletions(-)
 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/server/Model')

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