Start of Sprint 2

SpockOpaleye/SpockOpaleye.cabal

@@ -16,23 +16,26 @@ cabal-version:       >=1.10
 library
   hs-source-dirs:      src
   exposed-modules:     Lib,
+                       DataTypes,
+                       ApiBase, 
                        TenantApi,
                        UserApi,
                        RoleApi,
                        OpaleyeDef,
                        CryptoDef,
                        JsonInstances,
-                       Validations,
-                       DataTypes
+                       Validations
   build-depends:       base >= 4.7 && < 5
                       ,product-profunctors
                       ,bytestring
                       ,opaleye
+                      ,time
                       ,postgresql-simple
                       ,bcrypt
                       ,text
                       ,lens
                       ,mtl
+                      ,vector
                       ,Spock >=0.11
                       ,aeson
   default-language:    Haskell2010
@@ -49,6 +52,7 @@ executable SpockOpaleye-exe
                      , lens
                      , text
                      , bcrypt
+                     , vector
                      , aeson
   default-language:    Haskell2010
 

SpockOpaleye/app/Main.hs

@@ -34,15 +34,12 @@ app :: SpockM Connection MySession MyAppState ()
 app = do
   post ("tenants/new") $
     do maybe_tenant_incoming <- jsonBody
-       maybe_newtenant <-
-         case maybe_tenant_incoming of
-           Just incoming_tenant -> do
-             result <-
-               runQuery (\conn -> validateIncomingTenant conn incoming_tenant)
-             case result of
-               Valid -> runQuery (\conn -> create_tenant conn incoming_tenant)
-               _ -> return Nothing
-           Nothing -> return Nothing
-       case maybe_newtenant of
-         Just tenant -> json tenant
-         _           -> json $ T.pack "Tenant not created"
+       case maybe_tenant_incoming of
+         Just incoming_tenant -> do
+           result <- runQuery (\conn -> validateIncomingTenant conn incoming_tenant)
+           case result of
+             Valid -> do
+                  new_tenant <- runQuery (\conn -> create_tenant conn incoming_tenant)
+                  json new_tenant
+             _ -> json $ T.pack "Validation fail"
+         Nothing -> json $ T.pack "Unrecognized input"

SpockOpaleye/src/ApiBase.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module ApiBase where
+
+import           Control.Lens
+import qualified Data.Profunctor.Product.Default as D
+import           Data.Time                       (UTCTime, getCurrentTime)
+import           Database.PostgreSQL.Simple
+import           DataTypes
+import           Opaleye
+import           OpaleyeDef
+import           OpaleyeTypes
+import           Prelude                         hiding (id)
+
+create_row ::(
+    HasCreatedat columnsW (Maybe (Column PGTimestamptz)),
+    HasUpdatedat columnsW (Column PGTimestamptz),
+    D.Default Constant incoming columnsW, D.Default QueryRunner returned row)
+    => Connection -> Table columnsW returned -> incoming -> IO row
+create_row conn table item = do
+  current_time <- fmap pgUTCTime getCurrentTime
+  let itemPg = (constant item) & createdat .~ (Just current_time) & updatedat .~ (current_time)
+  fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x)
+
+update_row :: (
+    HasUpdatedat haskells 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_row 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 (UTCTime)) => UTCTime -> item -> item
+    put_updated_timestamp timestamp  = updatedat .~ timestamp
+    match_func :: (HasId cmR (Column PGInt4)) => (cmR -> Column PGBool)
+    match_func item = (item ^. id) .== (constant it_id)

SpockOpaleye/src/DataTypes.hs

@@ -1,11 +1,22 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeSynonymInstances   #-}
 
 module DataTypes where
 
+import           Control.Lens
 import           CryptoDef
 import           Data.List.NonEmpty
+import qualified Data.Profunctor.Product.Default as D
 import           Data.Text
+import           Data.Time                       (UTCTime)
+import           Data.Time                       (UTCTime, getCurrentTime)
 import           GHC.Generics
+import           Opaleye
 
 data ValidationResult = Valid | Invalid
   deriving (Eq, Show)
@@ -16,51 +27,66 @@ newtype TenantId = TenantId Int
 data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew
   deriving (Show, Generic)
 
-data TenantPoly key name fname lname email phone status owner_id b_domain = Tenant
-  { tenant_id               :: key
-  , tenant_name             :: name
-  , tenant_firstname        :: fname
-  , tenant_lastname         :: lname
-  , tenant_email            :: email
-  , tenant_phone            :: phone
-  , tenant_status           :: status
-  , tenant_ownerid          :: owner_id
-  , tenant_backofficedomain :: b_domain
-  } deriving (Show, Generic)
+data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant {
+    _tenantpolyId               :: key
+  , _tenantpolyCreatedat        :: created_at
+  , _tenantpolyUpdatedat        :: updated_at
+  , _tenantpolyName             :: name
+  , _tenantpolyFirstname        :: fname
+  , _tenantpolyLastname         :: lname
+  , _tenantpolyEmail            :: email
+  , _tenantpolyPhone            :: phone
+  , _tenantpolyStatus           :: status
+  , _tenantpolyOwnerid          :: owner_id
+  , _tenantpolyBackofficedomain :: b_domain
+} deriving (Show, Generic)
 
-type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus (Maybe UserId) Text
 
-type TenantIncoming = TenantPoly () Text Text Text Text Text () (Maybe UserId) Text
+type Tenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text
+
+type TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text
+type TenantIncomingCreatable = TenantPoly () UTCTime UTCTime Text Text Text Text Text () (Maybe UserId) Text
 
 data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked
   deriving (Show)
 
 newtype UserId = UserId Int
   deriving (Show, Generic)
 
-data UserPoly key tenant_id username password firstname lastname status  = User {
-  user_id        :: key,
-  user_tenantid  :: tenant_id,
-  user_username  :: username,
-  user_password  :: password,
-  user_firstname :: firstname,
-  user_lastname  :: lastname,
-  user_status    :: status
+data UserPoly key created_at updated_at tenant_id username password firstname lastname status  = User {
+    _userpolyId        :: key
+  , _userpolyCreatedat :: created_at
+  , _userpolyUpdatedat :: updated_at
+  , _userpolyTenantid  :: tenant_id
+  , _userpolyUsername  :: username
+  , _userpolyPassword  :: password
+  , _userpolyFirstname :: firstname
+  , _userpolyLastname  :: lastname
+  , _userpolyStatus    :: status
 }
 
-type User = UserPoly UserId TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus
+type User = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus
+
+type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) ()
 
 data Permission = Read | Create | Update | Delete
   deriving (Show)
 
 newtype RoleId = RoleId Int
   deriving (Show)
 
-data RolePoly key tenant_id name permission = Role
-  { role_id         :: key
-  , role_tenantid   :: tenant_id
-  , role_name       :: name
-  , role_permission :: permission
-  } deriving (Show)
-
-type Role = RolePoly RoleId TenantId Text (NonEmpty Permission)
+data RolePoly key tenant_id name permission created_at updated_at  = Role {
+    _rolepolyId         :: key
+  , _rolepolyTenantid   :: tenant_id
+  , _rolepolyName       :: name
+  , _rolepolyPermission :: permission
+  , _rolepolyCreatedat  :: created_at
+  , _rolepolyUpdatedat  :: updated_at
+} deriving (Show)
+
+type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime
+type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () ()
+
+makeLensesWith abbreviatedFields ''RolePoly
+makeLensesWith abbreviatedFields ''TenantPoly
+makeLensesWith abbreviatedFields ''UserPoly

SpockOpaleye/src/JsonInstances.hs

@@ -7,6 +7,7 @@ module JsonInstances where
 import           Control.Monad
 import           Data.Aeson
 import           Data.Aeson.Types
+import           Data.Char
 import           Data.Text
 import           DataTypes
 
@@ -29,7 +30,7 @@ instance FromJSON TenantStatus where
 
 instance FromJSON TenantIncoming where
   parseJSON (Object v) =
-    (Tenant ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*>
+    (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*>
     v .: "email" <*>
     v .: "phone" <*>
     (pure ()) <*>
@@ -38,11 +39,7 @@ instance FromJSON TenantIncoming where
 
 instance ToJSON TenantStatus where
   toJSON = genericToJSON defaultOptions
-  toEncoding =
-    genericToEncoding
-      defaultOptions
-      { constructorTagModifier = tg_modify
-      }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tg_modify }
     where
       tg_modify :: String -> String
       tg_modify "TenantStatusActive"   = "active"
@@ -51,13 +48,9 @@ instance ToJSON TenantStatus where
 
 instance ToJSON Tenant where
   toJSON = genericToJSON defaultOptions
-  toEncoding =
-    genericToEncoding
-      defaultOptions
-      { fieldLabelModifier = remove_prefix
-      }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).remove_prefix }
     where
-      remove_prefix = Prelude.drop 7
+      remove_prefix = Prelude.drop 11
 
 instance ToJSON UserId where
   toJSON = genericToJSON defaultOptions