From 722205b0818a7fb2280941554baaff9400808d65 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Sat, 25 Jul 2020 18:32:17 +0100
Subject: [PATCH] Remodel Account type

Remove unnecessary fields:
- name
- age

Add domain-specific fields:
- username
- password
- email
- role
---
 src/App.hs   |  4 ++--
 src/Types.hs | 29 ++++++++++++++++++++---------
 2 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/src/App.hs b/src/App.hs
index 40dc23a30..a13ffa2d3 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -32,7 +32,7 @@ server pool =
 
     userAdd :: T.Account -> IO (Maybe T.Session)
     userAdd newUser = flip runSqlPersistMPool pool $ do
-      exists <- selectFirst [T.AccountName ==. (T.accountName newUser)] []
+      exists <- selectFirst [T.AccountUsername ==. (T.accountUsername newUser)] []
       case exists of
         Nothing -> do
           insert newUser
@@ -44,7 +44,7 @@ server pool =
 
     userGet :: Text -> IO (Maybe T.Account)
     userGet name = flip runSqlPersistMPool pool $ do
-      mUser <- selectFirst [T.AccountName ==. name] []
+      mUser <- selectFirst [T.AccountUsername ==. name] []
       pure $ entityVal <$> mUser
 
 app :: ConnectionPool -> Application
diff --git a/src/Types.hs b/src/Types.hs
index 813a4b51c..fc1516e5b 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NamedFieldPuns #-}
 --------------------------------------------------------------------------------
 module Types where
 --------------------------------------------------------------------------------
@@ -17,21 +18,31 @@ import Database.Persist.TH
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 Account
-  name Text
-  age  Int
-  UniqueName name
+  username Text
+  password Text
+  email Text
+  role Text
+  UniqueUsername username
+  UniqueEmail email
   deriving Eq Read Show
 |]
 
 instance FromJSON Account where
-  parseJSON = withObject "User" $ \ v ->
-    Account <$> v .: "name"
-            <*> v .: "age"
+  parseJSON = withObject "Account" $ \ v ->
+    Account <$> v .: "username"
+            <*> v .: "password"
+            <*> v .: "email"
+            <*> v .: "role"
 
 instance ToJSON Account where
-  toJSON (Account name age) =
-    object [ "name" .= name
-           , "age"  .= age
+  toJSON (Account{ accountUsername
+                 , accountPassword
+                 , accountEmail
+                 , accountRole }) =
+    object [ "username" .= accountUsername
+           , "password" .= accountPassword
+           , "email" .= accountEmail
+           , "role" .= accountRole
            ]
 
 newtype Username = Username Text