Merge pull request #4 from eldr-io/fix/rename-user-model

fix #2 - Refactor user model to "guest" to avoid postgres internals name clash

README.md

@@ -80,7 +80,7 @@ make test-integration
 
 #### Changing the routes and templates
 
-Hastl allows you to combine strongly-typed Servant APIs to make up your application. To add a new route and endpoint, you can create a new file similar to `lib/Api/User.hs` e.g. if you wanted to create a Todo-list API you could create `lib/Api/Todo.hs`. Additionally, you can create a new directory within `lib/Api/Templates` to store your Lucid-powered Haskell template files. Within the template files, you have access to the full power of HTMX and Alpine through helper functions.
+Hastl allows you to combine strongly-typed Servant APIs to make up your application. To add a new route and endpoint, you can create a new file similar to `lib/Api/Guest.hs` e.g. if you wanted to create a Todo-list API you could create `lib/Api/Todo.hs`. Additionally, you can create a new directory within `lib/Api/Templates` to store your Lucid-powered Haskell template files. Within the template files, you have access to the full power of HTMX and Alpine through helper functions.
 
 If you wish to use persistent models in your application, you can define your models in `lib/Models.hs` and persistent will automatically create the Haskell types, as well as handling the database migrations for DEVELOPMENT setups (note: is it recommended to use a more robust migration mechanism for production).
 

hastl.cabal

@@ -23,9 +23,9 @@ library
       , Init
       , Models
       , Api
-      , Api.User
+      , Api.Guest
       , Api.Base
-      , Api.Templates.User.User
+      , Api.Templates.Guest.Guest
       , Api.Templates.Base.Footer
       , Api.Templates.Base.Header
       , Api.Templates.Base.Home
@@ -89,7 +89,7 @@ test-suite hastl-test
     import:           warnings
     default-language: GHC2021
     other-modules:
-      Api.UserSpec
+      Api.GuestSpec
     default-extensions:
       OverloadedStrings
     type:             exitcode-stdio-1.0

lib/Api.hs

@@ -12,15 +12,15 @@ import Servant (
  )
 import Servant.Server
 
-import Api.User (UserAPI, userApi, userServer)
+import Api.Guest (GuestAPI, guestApi, guestServer)
 import Api.Base (BaseAPI, baseApi, baseServer)
 import Config (AppT (..), Config (..))
 
 {- | This functions tells Servant how to run the 'App' monad with our
 'server' function.
 -}
-appToUserServer :: Config -> Server UserAPI
-appToUserServer cfg = hoistServer userApi (convertApp cfg) userServer
+appToGuestServer :: Config -> Server GuestAPI
+appToGuestServer cfg = hoistServer guestApi (convertApp cfg) guestServer
 
 
 appToBaseServer :: Config -> Server BaseAPI
@@ -46,7 +46,7 @@ two different APIs and applications. This is a powerful tool for code
 reuse and abstraction! We need to put the 'Raw' endpoint last, since it
 always succeeds.
 -}
-type AppAPI = UserAPI :<|> BaseAPI :<|> Raw
+type AppAPI = GuestAPI :<|> BaseAPI :<|> Raw
 
 appApi :: Proxy AppAPI
 appApi = Proxy
@@ -56,6 +56,6 @@ alongside the 'Raw' endpoint that serves all of our files.
 -}
 app :: Config -> Application
 app cfg = do
-  let userServerCfg = appToUserServer cfg
+  let userServerCfg = appToGuestServer cfg
       appServerCfg = appToBaseServer cfg
   serve appApi (userServerCfg :<|> appServerCfg :<|> files)

lib/Api/User.hs → lib/Api/Guest.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Api.User where
+module Api.Guest where
 
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Logger (logDebugNS, logErrorNS)
@@ -26,48 +26,48 @@ import Servant (
   type (:>),
  )
 
-import Api.Templates.User.User (renderUser, renderUsersComponent)
+import Api.Templates.Guest.Guest (renderGuest, renderGuestsComponent)
 import Config (AppT (..))
 import Data.Aeson (FromJSON)
 import Data.Text (Text, pack)
 import Data.Time (getCurrentTime)
 import GHC.Generics (Generic)
 import Lucid (Html, ToHtml (toHtml), class_, div_, id_, renderBS)
-import Models (User (User), runDb, tryRunDb)
+import Models (Guest (Guest), runDb, tryRunDb)
 import Servant.API.ContentTypes.Lucid (HTML)
 
-data CreateUserPayload = CreateUserPayload
+data CreateGuestPayload = CreateGuestPayload
   { name :: Text
   , email :: Text
   }
   deriving (Generic)
 
-instance FromJSON CreateUserPayload
+instance FromJSON CreateGuestPayload
 
-type UserAPI =
-  "users" :> Get '[HTML] (Html ())
-    :<|> "users" :> ReqBody '[JSON] CreateUserPayload :> Post '[HTML] (Html ())
+type GuestAPI =
+  "guests" :> Get '[HTML] (Html ())
+    :<|> "guests" :> ReqBody '[JSON] CreateGuestPayload :> Post '[HTML] (Html ())
 
-userApi :: Proxy UserAPI
-userApi = Proxy
+guestApi :: Proxy GuestAPI
+guestApi = Proxy
 
--- | The server that runs the UserAPI
-userServer :: (MonadIO m) => ServerT UserAPI (AppT m)
-userServer = allUsers :<|> createUser
+-- | The server that runs the guestAPI
+guestServer :: (MonadIO m) => ServerT GuestAPI (AppT m)
+guestServer = allGuests :<|> createGuest
 
--- | Returns all users in the database.
-allUsers :: (MonadIO m) => AppT m (Html ())
-allUsers = do
-  logDebugNS "web" "allUsers"
-  users :: [Entity User] <- runDb (selectList [] [])
-  return $ renderUsersComponent users
+-- | Returns all guests in the database.
+allGuests :: (MonadIO m) => AppT m (Html ())
+allGuests = do
+  logDebugNS "web" "allGuests"
+  guests :: [Entity Guest] <- runDb (selectList [] [])
+  return $ renderGuestsComponent guests
 
--- | Creates a user in the database.
-createUser :: (MonadIO m) => CreateUserPayload -> AppT m (Html ())
-createUser u = do
-  logDebugNS "web" "creating a user"
+-- | Creates a guest in the database.
+createGuest :: (MonadIO m) => CreateGuestPayload -> AppT m (Html ())
+createGuest u = do
+  logDebugNS "web" "creating a guest"
   time <- liftIO getCurrentTime
-  result <- tryRunDb (insert (User (name u) (email u) time))
+  result <- tryRunDb (insert (Guest (name u) (email u) time))
   case result of
     Left exception -> do
       logErrorNS "web" (Data.Text.pack (show exception))
@@ -88,13 +88,13 @@ createUser u = do
           , errHTTPCode = 200 -- This is a hack to make sure htmx displays our error
           }
     Right key -> do
-      logDebugNS "web" "User created"
-      maybeUser <- runDb (getEntity key)
-      case maybeUser of
+      logDebugNS "web" "guest created"
+      maybeGuest <- runDb (getEntity key)
+      case maybeGuest of
         Nothing -> do
           logErrorNS
             "web"
-            "Failed to create user"
+            "Failed to create guest"
           throwError err500
-        Just user ->
-          return $ renderUser user
+        Just guest ->
+          return $ renderGuest guest

lib/Api/Templates/Base/Home.hs

@@ -1,7 +1,7 @@
 module Api.Templates.Base.Home where
 
 import Api.Templates.Helpers.Htmx (hxGet_, hxSwap_, hxTrigger_)
-import Api.Templates.User.User (renderAddUserForm)
+import Api.Templates.Guest.Guest (renderAddGuestForm)
 import Data.Text (Text)
 import Lucid (
   Html,
@@ -39,9 +39,9 @@ renderHome =
         br_ []
         renderBadges
         p_ [class_ "text-gray-600 mt-5"] "Try it out below by adding guests to your awesome party!"
-        renderAddUserForm
+        renderAddGuestForm
         p_ [class_ "text-xs text-gray-500 mt-2 mx-auto text-center"] "* Don't worry, we won't actually send anything!"
-    div_ [hxGet_ "/users", hxSwap_ "innerHTML", hxTrigger_ "load"] $ p_ "Loading..."
+    div_ [hxGet_ "/guests", hxSwap_ "innerHTML", hxTrigger_ "load"] $ p_ "Loading..."
 
 renderBadge :: Text -> Html ()
 renderBadge src = img_ [class_ "col-span-1 inline", src_ src]

lib/Api/Templates/User/User.hs → lib/Api/Templates/Guest/Guest.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 
-module Api.Templates.User.User where
+module Api.Templates.Guest.Guest where
 
 import Api.Templates.Helpers.Htmx (hxExt_, hxPost_, hxSwap_, hxTarget_)
 import Data.Text qualified as T
@@ -26,18 +26,18 @@ import Lucid (
   type_,
   ul_,
  )
-import Models (User (userName))
+import Models (Guest (guestName))
 
-renderAddUserForm :: Html ()
-renderAddUserForm = do
+renderAddGuestForm :: Html ()
+renderAddGuestForm = do
   div_ [id_ "form-errors", class_ ""] mempty
   div_
-    [ id_ "add-user-form"
-    , class_ "add-user-form shadow-md rounded-md overflow-hidden max-w-fit mx-auto mt-16"
+    [ id_ "add-guest-form"
+    , class_ "add-guest-form shadow-md rounded-md overflow-hidden max-w-fit mx-auto mt-16"
     ]
     $ do
-      div_ [class_ "bg-gray-100 px-4 py-2"] $ p_ "Add a Party Animal"
-      form_ [hxPost_ "/users", hxTarget_ "#users-ul", hxSwap_ "afterbegin transition:true", hxExt_ "json-enc"] $ do
+      div_ [class_ "bg-gray-100 px-4 py-2"] $ p_ "Add a Party Guest"
+      form_ [hxPost_ "/guests", hxTarget_ "#guests-ul", hxSwap_ "afterbegin transition:true", hxExt_ "json-enc"] $ do
         input_
           [ class_ "w-full px-4 py-2 border border-gray-200 rounded-md"
           , type_ "text"
@@ -54,34 +54,34 @@ renderAddUserForm = do
           [ class_ "w-full px-4 py-2 bg-primary hover:bg-violet-500 text-white rounded-md mt-2"
           , type_ "submit"
           ]
-          "Invite to your party"
+          "Invite guest to your party"
 
-renderUsersComponent :: [Entity User] -> Html ()
-renderUsersComponent users =
+renderGuestsComponent :: [Entity Guest] -> Html ()
+renderGuestsComponent guests =
   div_
-    [ id_ "users"
-    , class_ "users bg-white shadow-md rounded-md overflow-hidden max-w-xl mx-auto mt-14"
+    [ id_ "guests"
+    , class_ "guests bg-white shadow-md rounded-md overflow-hidden max-w-xl mx-auto mt-14"
     ]
     $ do
       div_ [class_ "bg-gray-100 px-4 py-2"] $ p_ "Party Goers"
-      renderUsers users
+      renderGuests guests
 
-renderUser :: Entity User -> Html ()
-renderUser user = do
-  let userId = show (fromSqlKey (entityKey user))
-      name = userName (entityVal user)
+renderGuest :: Entity Guest -> Html ()
+renderGuest guest = do
+  let guestId = show (fromSqlKey (entityKey guest))
+      name = guestName (entityVal guest)
   li_ [class_ "flex items-center px-6 py-4 smooth"] $ do
     img_
       [ class_ "w-12 h-12 rounded-full object-cover mr-4"
-      , src_ ("https://randomuser.me/api/portraits/women/" <> T.pack userId <> ".jpg")
-      , alt_ "User"
+      , src_ ("https://randomuser.me/api/portraits/women/" <> T.pack guestId <> ".jpg")
+      , alt_ "Guest"
       ]
     div_ [class_ "flex-1"] $ do
       h3_ [class_ "text-lg font-medium text-gray-800"] (toHtml name)
       p_ [class_ "text-sm font-normal text-gray-600"] "Party Animal"
 
-renderUsers :: [Entity User] -> Html ()
-renderUsers [] = ul_ [id_ "users-ul", class_ "divide-y divide-gray-200"] $ li_ [] mempty
-renderUsers users = do
-  ul_ [id_ "users-ul", class_ "divide-y divide-gray-200"] $ do
-    mapM_ renderUser users
+renderGuests :: [Entity Guest] -> Html ()
+renderGuests [] = ul_ [id_ "guests-ul", class_ "divide-y divide-gray-200"] $ li_ [] mempty
+renderGuests guests = do
+  ul_ [id_ "guests-ul", class_ "divide-y divide-gray-200"] $ do
+    mapM_ renderGuest guests

lib/Models.hs

@@ -37,7 +37,7 @@ share
   , mkMigrate "migrateAll"
   ]
   [persistLowerCase|
-User json
+Guest json
     name Text
     email Text
     createdAt UTCTime default=now()

test/Api/GuestSpec.hs

@@ -0,0 +1,26 @@
+module Api.GuestSpec where
+
+import Data.Time (getCurrentTime)
+import Models (Guest (Guest), guestCreatedAt, guestEmail, guestName)
+import Test.Hspec (Spec, before, context, describe, it, shouldBe)
+
+spec :: Spec
+spec = before
+  ( do
+      time <- getCurrentTime
+      pure time
+  )
+  $ do
+    describe "templates" $ do
+      context "when rendering a guest" $ do
+        it "renders a guest" $
+          ( \currentTime -> do
+              let guest =
+                    Guest
+                      { guestName = "bobby"
+                      , guestEmail = "[email protected]"
+                      , guestCreatedAt = currentTime
+                      }
+              -- let entity = Entity (Key user) user
+              guestName guest `shouldBe` "bobby"
+          )