From 3b738e0d4cc65f314da7389d4542ec826ba0f454 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 5 Sep 2015 13:53:36 +0200
Subject: Using UserId instead of UserName to indentify users

---
 src/server/Controller/Index.hs        | 38 -----------------------------------
 src/server/Controller/User.hs         | 25 +++++++++++++++++++++++
 src/server/Main.hs                    | 23 +++++++++------------
 src/server/Model/Json/Payment.hs      |  6 ++++--
 src/server/Model/Json/TotalPayment.hs |  4 +++-
 src/server/Model/Json/User.hs         | 21 +++++++++++++++++++
 src/server/Model/Payment.hs           | 15 +++++---------
 src/server/Model/User.hs              | 11 ++++++++--
 8 files changed, 76 insertions(+), 67 deletions(-)
 create mode 100644 src/server/Controller/User.hs
 create mode 100644 src/server/Model/Json/User.hs

(limited to 'src/server')

diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index 2d8c40c..17f5ae9 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -1,58 +1,20 @@
 module Controller.Index
   ( getIndexAction
-  , getUserName
   , signOutAction
-  , getUsersAction
-  , addUserAction
-  , deleteUserAction
   ) where
 
 import Web.Scotty
 
 import Network.HTTP.Types.Status (ok200)
 
-import Database.Persist
-
-import Control.Monad.IO.Class (liftIO)
-
-import Data.Text (Text)
-import Data.String (fromString)
-
 import qualified LoginSession
 
-import qualified Secure
-
-import Model.Database
-import Model.User
-import Model.Json.Message
-
 import View.Page (page)
 
 getIndexAction :: ActionM ()
 getIndexAction = html page
 
-getUserName :: ActionM ()
-getUserName =
-  Secure.loggedAction (\user -> do
-    json . Message . userName . entityVal $ user
-  )
-
 signOutAction :: ActionM ()
 signOutAction = do
   LoginSession.delete
   status ok200
-
-getUsersAction :: ActionM ()
-getUsersAction = do
-  users <- liftIO $ runDb getUsers
-  html . fromString . show $ users
-
-addUserAction :: Text -> Text -> ActionM ()
-addUserAction email name = do
-  _ <- liftIO . runDb $ createUser email name
-  status ok200
-
-deleteUserAction :: Text -> ActionM ()
-deleteUserAction email = do
-  _ <- liftIO . runDb $ deleteUser email
-  status ok200
diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs
new file mode 100644
index 0000000..95e5fa8
--- /dev/null
+++ b/src/server/Controller/User.hs
@@ -0,0 +1,25 @@
+module Controller.User
+  ( getUsersAction
+  , whoAmIAction
+  ) where
+
+import Web.Scotty
+
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Secure
+
+import Model.Database
+import Model.User
+
+getUsersAction :: ActionM ()
+getUsersAction =
+  Secure.loggedAction (\_ -> do
+    (liftIO $ map getJsonUser <$> runDb getUsers) >>= json
+  )
+
+whoAmIAction :: ActionM ()
+whoAmIAction =
+  Secure.loggedAction (\user -> do
+    json (getJsonUser user)
+  )
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 8a77598..27908b4 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -10,6 +10,7 @@ import qualified Data.Text.IO as TIO
 import Controller.Index
 import Controller.SignIn
 import Controller.Payment
+import Controller.User
 
 import Model.Database (runMigrations)
 
@@ -39,8 +40,14 @@ main = do
           token <- param "token" :: ActionM Text
           validateSignInAction config token
 
-        get "/userName" $
-          getUserName
+        post "/signOut" $
+          signOutAction
+
+        get "/whoAmI" $
+          whoAmIAction
+
+        get "/users" $ do
+          getUsersAction
 
         get "/payments" $ do
           page <- param "page" :: ActionM Int
@@ -61,15 +68,3 @@ main = do
 
         get "/payments/count" $ do
           getPaymentsCountAction
-
-        post "/signOut" $
-          signOutAction
-
-        get "/users" getUsersAction
-        post "/user/add" $ do
-          email <- param "email" :: ActionM Text
-          name <- param "name" :: ActionM Text
-          addUserAction email name
-        post "/user/delete" $ do
-          email <- param "email" :: ActionM Text
-          deleteUserAction email
diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs
index f22c8cf..8923c13 100644
--- a/src/server/Model/Json/Payment.hs
+++ b/src/server/Model/Json/Payment.hs
@@ -10,12 +10,14 @@ import Data.Time
 import Data.Text (Text)
 import Data.Aeson
 
+import Model.Database (PaymentId, UserId)
+
 data Payment = Payment
-  { id :: Text
+  { id :: PaymentId
   , creation :: UTCTime
   , name :: Text
   , cost :: Int
-  , userName :: Text
+  , userId :: UserId
   } deriving (Show, Generic)
 
 instance FromJSON Payment
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
index e386c79..5ae68c9 100644
--- a/src/server/Model/Json/TotalPayment.hs
+++ b/src/server/Model/Json/TotalPayment.hs
@@ -9,8 +9,10 @@ import GHC.Generics
 import Data.Text (Text)
 import Data.Aeson
 
+import Model.Database (UserId)
+
 data TotalPayment = TotalPayment
-  { userName :: Text
+  { userId :: UserId
   , totalPayment :: Int
   } deriving (Show, Generic)
 
diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs
new file mode 100644
index 0000000..ebc347b
--- /dev/null
+++ b/src/server/Model/Json/User.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.User
+  ( User(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Text (Text)
+
+import Model.Database (UserId)
+
+data User = User
+  { id :: UserId
+  , name :: Text
+  , email :: Text
+  } deriving (Show, Generic)
+
+instance FromJSON User
+instance ToJSON User
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index ce8c5a1..d7632f0 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,14 +1,12 @@
 module Model.Payment
   ( getPayments
   , createPayment
-  , paymentKeyToText
   , deleteOwnPayment
   , getTotalPayments
   , getPaymentsCount
   ) where
 
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Maybe (catMaybes)
 
@@ -40,16 +38,13 @@ getJsonPayment (paymentEntity, userEntity) =
   let payment = entityVal paymentEntity
       user = entityVal userEntity
   in  P.Payment
-        { P.id = paymentKeyToText . entityKey $ paymentEntity
+        { P.id = entityKey paymentEntity
         , P.creation = paymentCreation payment
         , P.name = paymentName payment
         , P.cost = paymentCost payment
-        , P.userName = userName user
+        , P.userId = entityKey userEntity
         }
 
-paymentKeyToText :: Key Payment -> Text
-paymentKeyToText = T.pack . show . unSqlBackendKey . unPaymentKey
-
 createPayment :: UserId -> Text -> Int -> Persist PaymentId
 createPayment userId name cost = do
   now <- liftIO getCurrentTime
@@ -77,11 +72,11 @@ getTotalPayments = do
               on (payment ^. PaymentUserId E.==. user ^. UserId)
               where_ (isNothing (payment ^. PaymentDeletedAt))
               groupBy (payment ^. PaymentUserId)
-              return (user ^. UserName, sum_ (payment ^. PaymentCost))
+              return (user ^. UserId, sum_ (payment ^. PaymentCost))
   return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
 
-getTotalPayment :: (Text, Maybe Int) -> Maybe TP.TotalPayment
-getTotalPayment (userName, Just cost) = Just (TP.TotalPayment userName cost)
+getTotalPayment :: (UserId, Maybe Int) -> Maybe TP.TotalPayment
+getTotalPayment (userId, Just cost) = Just (TP.TotalPayment userId cost)
 getTotalPayment (_, Nothing) = Nothing
 
 unValueTuple :: (Value a, Value b) -> (a, b)
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
index 339aff6..2b52d03 100644
--- a/src/server/Model/User.hs
+++ b/src/server/Model/User.hs
@@ -1,6 +1,7 @@
 module Model.User
   ( getUsers
   , getUser
+  , getJsonUser
   , createUser
   , deleteUser
   ) where
@@ -13,13 +14,19 @@ import Control.Monad.IO.Class (liftIO)
 import Database.Persist
 
 import Model.Database
+import qualified Model.Json.User as Json
 
-getUsers :: Persist [User]
-getUsers = map entityVal <$> selectList [] [Desc UserCreation]
+getUsers :: Persist [Entity User]
+getUsers = selectList [] [Desc UserCreation]
 
 getUser :: Text -> Persist (Maybe (Entity User))
 getUser email = selectFirst [UserEmail ==. email] []
 
+getJsonUser :: Entity User -> Json.User
+getJsonUser userEntity =
+  let user = entityVal userEntity
+  in  Json.User (entityKey userEntity) (userName user) (userEmail user)
+
 createUser :: Text -> Text -> Persist UserId
 createUser email name = do
   now <- liftIO getCurrentTime
-- 
cgit v1.2.3