Split the generic insert/update function in a separate module

SpockOpaleye/src/ApiBase.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module ApiBase where
+
+import qualified Data.Profunctor.Product.Default      as D
+import           Data.Time                            (UTCTime, getCurrentTime)
+import           Control.Lens
+import           DataTypes
+import           Database.PostgreSQL.Simple
+import Opaleye
+import OpaleyeDef
+import Prelude hiding (id)
+
+create_item :: (
+      HasCreatedat haskells (Maybe UTCTime)
+    , D.Default Constant haskells columnsW
+    , D.Default QueryRunner returned b)
+    => Connection -> Table columnsW returned -> haskells -> IO b
+create_item conn table item = do
+  current_time <- getCurrentTime
+  let cl = createdat .~ Just current_time
+  fmap head $ runInsertManyReturning conn table [constant $ cl item] (\x -> x)
+
+update_item :: (
+    HasUpdatedat haskells (Maybe UTCTime)
+    , D.Default Constant haskells columnsW
+    , D.Default Constant item_id (Column PGInt4)
+    , HasId haskells item_id
+    , HasId columnsR (Column PGInt4)
+    )
+    => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO haskells
+update_item conn table it_id item = do
+  current_time <- getCurrentTime
+  let updated_item = (put_updated_timestamp current_time) item
+  runUpdate conn table (\_ -> constant updated_item) match_func
+  return updated_item
+  where
+    put_updated_timestamp :: (HasUpdatedat item (Maybe UTCTime)) => UTCTime -> item -> item
+    put_updated_timestamp timestamp  = updatedat .~ Just timestamp
+    match_func :: (HasId cmR (Column PGInt4)) => (cmR -> Column PGBool)
+    match_func item = (item ^. id) .== (constant it_id)

SpockOpaleye/src/DataTypes.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FunctionalDependencies      #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module DataTypes where
@@ -80,6 +82,6 @@ data RolePoly key tenant_id name permission created_at updated_at  = Role {
 type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime)
 type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime)
 
-makeFields ''RolePoly
-makeFields ''TenantPoly
-makeFields ''UserPoly
+makeLensesWith abbreviatedFields ''RolePoly
+makeLensesWith abbreviatedFields ''TenantPoly
+makeLensesWith abbreviatedFields ''UserPoly

SpockOpaleye/src/OpaleyeDef.hs

@@ -51,7 +51,6 @@ type TenantTableR = TenantPoly
   (Column PGText)
 
 $(makeAdaptorAndInstance "pTenant" ''TenantPoly)
-$(makeLensesWith abbreviatedFields ''TenantPoly)
 
 tenantTable :: Table TenantTableW TenantTableR
 tenantTable = Table "tenants" (pTenant
@@ -93,7 +92,6 @@ type UserTableR = UserPoly
   (Column PGText)
 
 $(makeAdaptorAndInstance "pUser" ''UserPoly)
-$(makeLensesWith abbreviatedFields ''UserPoly)
 
 userTable :: Table UserTableW UserTableR
 userTable = Table "users" (pUser
@@ -126,7 +124,6 @@ type RoleTableR = RolePoly
   (Column PGTimestamptz) -- updatedAt
 
 $(makeAdaptorAndInstance "pRole" ''RolePoly)
-$(makeLensesWith abbreviatedFields ''RolePoly)
 
 roleTable :: Table RoleTableW RoleTableR
 roleTable = Table "roles" (pRole Role {

SpockOpaleye/src/UserApi.hs

@@ -28,6 +28,7 @@ import           OpaleyeDef
 import ApiBase
 
 import           CryptoDef
+import Prelude hiding (id)
 
 create_user :: Connection -> UserIncoming -> IO User
 create_user conn user = do
@@ -45,13 +46,13 @@ deactivate_user :: Connection -> User -> IO User
 deactivate_user conn user = set_user_status conn user UserStatusInActive
 
 set_user_status :: Connection -> User -> UserStatus -> IO User
-set_user_status conn user new_status = update_user conn (user ^. OpaleyeDef.id) $ user & status .~ new_status
+set_user_status conn user new_status = update_user conn (user ^. id) $ user & status .~ new_status
 
 remove_user :: Connection -> User -> IO GHC.Int.Int64
 remove_user conn user_t =
   runDelete conn userTable match_function
     where
-    match_function user = (user ^. OpaleyeDef.id).== constant (user_t ^. OpaleyeDef.id)
+    match_function user = (user ^. id).== constant (user_t ^. id)
 
 read_users :: Connection -> IO [User]
 read_users conn = runQuery conn user_query
@@ -80,7 +81,7 @@ user_query = queryTable userTable
 user_query_by_id :: UserId -> Query UserTableR
 user_query_by_id t_id = proc () -> do
   user <- user_query -< ()
-  restrict -< (user ^. OpaleyeDef.id) .== (constant t_id)
+  restrict -< (user ^. id) .== (constant t_id)
   returnA -< user
 
 user_query_by_tenantid :: TenantId -> Query UserTableR

SpockOpaleye/src/Validations.hs

@@ -15,20 +15,15 @@ import qualified Data.Text                  as T
 import           Database.PostgreSQL.Simple
 import           TenantApi
 
-test :: Tenant -> T.Text
-test tenant = tenant ^. name
-
 validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult
-validateIncomingTenant conn tenant = return Valid
---validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult
---validateIncomingTenant conn tenant = do
---  unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain)
---  return $
---    if and [unique_bod, validate_name, validate_contact]
---      then Valid
---      else Invalid
---  where
---    validate_contact = and $ (>= 0) . T.length <$> [tenant ^. firstname, tenant ^. lastname, tenant ^. email, tenant ^. phone]
---    validate_name = (T.length $ tenant ^. name) >= 3
---    check_for_unique_bo_domain domain =
---      isNothing <$> read_tenant_by_backofficedomain conn domain
+validateIncomingTenant conn tenant = do
+  unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain)
+  return $
+    if and [unique_bod, validate_name, validate_contact]
+      then Valid
+      else Invalid
+  where
+    validate_contact = and $ (>= 0) . T.length <$> [tenant ^. firstname, tenant ^. lastname, tenant ^. email, tenant ^. phone]
+    validate_name = (T.length $ tenant ^. name) >= 3
+    check_for_unique_bo_domain domain =
+      isNothing <$> read_tenant_by_backofficedomain conn domain