From 830d2eca120bcd97cc3a07f96f41c7e8da671e5a Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 4 Nov 2016 05:49:01 +0000 Subject: [PATCH 01/69] Formatting --- SpockOpaleye/src/TenantApi.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index a743fab..c595755 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -49,7 +49,7 @@ create_tenant conn tenant@Tenant { }) id return $ case tenants of [] -> Nothing - (x:xs) ->Just x + (x:xs) -> Just x activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive @@ -81,12 +81,12 @@ update_tenant conn t_tenantid tenant@Tenant { update_func x = Tenant { tenant_id = constant $ Just id ,tenant_name = pgStrictText name - ,tenant_firstname = pgStrictText first_name - ,tenant_lastname = pgStrictText last_name - ,tenant_email = pgStrictText email - ,tenant_phone = pgStrictText phone - ,tenant_status = constant status - ,tenant_ownerid = toNullable . constant <$> owner_id + ,tenant_firstname = pgStrictText first_name + ,tenant_lastname = pgStrictText last_name + ,tenant_email = pgStrictText email + ,tenant_phone = pgStrictText phone + ,tenant_status = constant status + ,tenant_ownerid = toNullable . constant <$> owner_id ,tenant_backofficedomain = pgStrictText bo_domain } From a43ee573b2ec6c2647b8b103996ca95facc3ddcd Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 4 Nov 2016 13:29:50 +0000 Subject: [PATCH 02/69] Insert records directily with out having to convert to PGW types --- SpockOpaleye/src/JsonInstances.hs | 12 ++---------- SpockOpaleye/src/OpaleyeDef.hs | 17 +++++++++++++++++ SpockOpaleye/src/TenantApi.hs | 23 ++--------------------- 3 files changed, 21 insertions(+), 31 deletions(-) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index c90e2a6..bea6c5a 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -38,11 +38,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,11 +47,7 @@ instance ToJSON TenantStatus where instance ToJSON Tenant where toJSON = genericToJSON defaultOptions - toEncoding = - genericToEncoding - defaultOptions - { fieldLabelModifier = remove_prefix - } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = remove_prefix } where remove_prefix = Prelude.drop 7 diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index daa5c5e..bc87459 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -204,6 +204,12 @@ instance D.Default Constant (UserId) (Column PGInt4) where def' :: UserId -> (Column PGInt4) def' (UserId id) = pgInt4 id +instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where + def = Constant def' + where + def' :: UserId -> (Column (Nullable PGInt4)) + def' (UserId id) = (toNullable.pgInt4) id + instance FromField UserId where fromField field mdata = do x <- fromField field mdata @@ -241,3 +247,14 @@ instance FromField TenantId where instance QueryRunnerColumnDefault PGInt4 TenantId where queryRunnerColumnDefault = fieldQueryRunnerColumn + +-- + +instance D.Default Constant () (Maybe (Column PGInt4)) where + def = Constant (\_ -> Nothing) + +instance D.Default Constant () (Column PGText) where + def = Constant (\_ -> "") + +instance D.Default Constant () (Column (Nullable PGText)) where + def = Constant (\_ -> toNullable $ pgStrictText "") diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index c595755..2532c1e 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -26,27 +26,8 @@ import RoleApi import UserApi create_tenant :: Connection -> TenantIncoming -> IO (Maybe Tenant) -create_tenant conn tenant@Tenant { - tenant_id = _ - ,tenant_name = name - ,tenant_firstname = first_name - ,tenant_lastname = last_name - ,tenant_email = email - ,tenant_phone = phone - ,tenant_status = _ - ,tenant_ownerid = owner_id - ,tenant_backofficedomain = bo_domain} = do - tenants <- runInsertManyReturning conn tenantTable (return Tenant { - tenant_id = Nothing - ,tenant_name = pgStrictText name - ,tenant_firstname = pgStrictText first_name - ,tenant_lastname = pgStrictText last_name - ,tenant_email = pgStrictText email - ,tenant_phone = pgStrictText phone - ,tenant_status = constant TenantStatusInActive - ,tenant_ownerid = toNullable . constant <$> owner_id - ,tenant_backofficedomain = pgStrictText bo_domain - }) id +create_tenant conn tenant = do + tenants <- runInsertManyReturning conn tenantTable [constant tenant] id return $ case tenants of [] -> Nothing (x:xs) -> Just x From 45c7a2d6cc50424204e5075d17b133e776ee2445 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 4 Nov 2016 18:11:50 +0000 Subject: [PATCH 03/69] Use the records directly without converting to thier PG counterparts while doing db manipulations --- SpockOpaleye/app/Main.hs | 21 ++++----- SpockOpaleye/src/OpaleyeDef.hs | 22 +++++++++ SpockOpaleye/src/RoleAPi.hs | 15 +----- SpockOpaleye/src/TenantApi.hs | 35 +++----------- SpockOpaleye/src/UserApi.hs | 85 +++++++--------------------------- 5 files changed, 57 insertions(+), 121 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 36fce98..9f85908 100644 --- a/SpockOpaleye/app/Main.hs +++ b/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" diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index bc87459..c155fb7 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -210,6 +210,12 @@ instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where def' :: UserId -> (Column (Nullable PGInt4)) def' (UserId id) = (toNullable.pgInt4) id +instance D.Default Constant (UserId) (Maybe (Column PGInt4)) where + def = Constant def' + where + def' :: UserId -> Maybe (Column PGInt4) + def' (UserId id) = Just $ pgInt4 id + instance FromField UserId where fromField field mdata = do x <- fromField field mdata @@ -225,6 +231,12 @@ instance D.Default Constant (RoleId) (Column PGInt4) where def' :: RoleId -> (Column PGInt4) def' (RoleId id) = pgInt4 id +instance D.Default Constant (RoleId) (Maybe (Column PGInt4)) where + def = Constant def' + where + def' :: RoleId -> Maybe (Column PGInt4) + def' (RoleId id) = Just $ pgInt4 id + instance FromField RoleId where fromField field mdata = do x <- fromField field mdata @@ -240,6 +252,12 @@ instance D.Default Constant (TenantId) (Column PGInt4) where def' :: TenantId -> (Column PGInt4) def' (TenantId id) = pgInt4 id +instance D.Default Constant (TenantId) (Maybe (Column PGInt4)) where + def = Constant def' + where + def' :: TenantId -> Maybe (Column PGInt4) + def' (TenantId id) = Just $ pgInt4 id + instance FromField TenantId where fromField field mdata = do x <- fromField field mdata @@ -258,3 +276,7 @@ instance D.Default Constant () (Column PGText) where instance D.Default Constant () (Column (Nullable PGText)) where def = Constant (\_ -> toNullable $ pgStrictText "") + +instance D.Default Constant Text (Column (Nullable PGText)) where + def = Constant (toNullable.pgStrictText) + diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 313c483..0be02e5 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -19,19 +19,8 @@ import GHC.Int import Opaleye import OpaleyeDef -create_role :: Connection -> Role -> IO (Maybe Role) -create_role conn role@Role { role_tenantid = tenant_id , role_name = name , role_permission = rp } = do - ids <- - runInsertManyReturning - conn roleTable (return Role { - role_id = Nothing, - role_tenantid = constant tenant_id, - role_name = pgStrictText name, - role_permission = constant rp - }) id - return $ case ids of - [] -> Nothing - (x:xs) -> Just x +create_role :: Connection -> Role -> IO Role +create_role conn role = fmap Prelude.head $ runInsertManyReturning conn roleTable [constant role] id remove_role :: Connection -> Role -> IO GHC.Int.Int64 remove_role conn Role {role_id = t_id} = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 2532c1e..f9c52e0 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -25,12 +25,9 @@ import OpaleyeDef import RoleApi import UserApi -create_tenant :: Connection -> TenantIncoming -> IO (Maybe Tenant) +create_tenant :: Connection -> TenantIncoming -> IO Tenant create_tenant conn tenant = do - tenants <- runInsertManyReturning conn tenantTable [constant tenant] id - return $ case tenants of - [] -> Nothing - (x:xs) -> Just x + fmap Prelude.head $ runInsertManyReturning conn tenantTable [constant tenant] id activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive @@ -39,37 +36,17 @@ deactivate_tenant :: Connection -> Tenant -> IO Tenant deactivate_tenant conn tenant = set_tenant_status conn tenant TenantStatusInActive set_tenant_status :: Connection -> Tenant -> TenantStatus -> IO Tenant -set_tenant_status conn tenant status = update_tenant conn (tenant_id tenant) - tenant { tenant_status = status } +set_tenant_status conn tenant status = update_tenant conn (tenant_id tenant) tenant { tenant_status = status } update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant -update_tenant conn t_tenantid tenant@Tenant { - tenant_id = id - ,tenant_name = name - ,tenant_firstname = first_name - ,tenant_lastname = last_name - ,tenant_email = email - ,tenant_phone = phone - ,tenant_status = status - ,tenant_ownerid = owner_id - ,tenant_backofficedomain = bo_domain} = do +update_tenant conn t_tenantid tenant = do runUpdate conn tenantTable update_func match_func return tenant where match_func :: TenantTableR -> Column PGBool - match_func Tenant { tenant_id = id } = id .== (constant t_tenantid) + match_func Tenant { tenant_id = id } = id .== constant t_tenantid update_func :: TenantTableR -> TenantTableW - update_func x = Tenant { - tenant_id = constant $ Just id - ,tenant_name = pgStrictText name - ,tenant_firstname = pgStrictText first_name - ,tenant_lastname = pgStrictText last_name - ,tenant_email = pgStrictText email - ,tenant_phone = pgStrictText phone - ,tenant_status = constant status - ,tenant_ownerid = toNullable . constant <$> owner_id - ,tenant_backofficedomain = pgStrictText bo_domain - } + update_func x = constant tenant remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 remove_tenant conn tenant@Tenant {tenant_id = tid} = do diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 6183ec5..b94a304 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -26,73 +26,27 @@ import OpaleyeDef import CryptoDef -create_user :: Connection -> User -> IO (Maybe User) -create_user conn user@User { - user_id = _ - ,user_tenantid = tenant_id - ,user_username = username - ,user_password = password - ,user_firstname = first_name - ,user_lastname = last_name - ,user_status = status - } = do - users <- - runInsertManyReturning conn userTable (return User { - user_id = Nothing - ,user_tenantid = constant tenant_id - ,user_username = pgStrictText username - ,user_password = constant password - ,user_firstname = toNullable . pgStrictText <$> first_name - ,user_lastname = toNullable . pgStrictText <$> last_name - ,user_status = constant status - }) id - return $ case users of - [] -> Nothing - (x:xs) -> Just x - -update_user :: Connection -> UserId -> User -> IO GHC.Int.Int64 -update_user conn (UserId tid) (User { - user_id = _ - ,user_tenantid = tenant_id - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = status }) = runUpdate conn userTable update_func match_func +create_user :: Connection -> User -> IO User +create_user conn user = Prelude.head <$> runInsertManyReturning conn userTable [constant user] id + +update_user :: Connection -> UserId -> User -> IO User +update_user conn user_id user = do + runUpdate conn userTable update_func match_func + return user where - update_func User { user_id = id } = User { - user_id = Just id - , user_tenantid = constant tenant_id - , user_username = pgStrictText username - , user_password = constant password - , user_firstname = toNullable . pgStrictText <$> firstname - , user_lastname = toNullable . pgStrictText <$> lastname - , user_status = constant status - } - match_func User { user_id = id } = id .== constant tid - -activate_user :: Connection -> User -> IO GHC.Int.Int64 + update_func :: UserTableR -> UserTableW + update_func _ = constant user + match_func :: UserTableR -> Column PGBool + match_func User { user_id = id } = id .== constant user_id + +activate_user :: Connection -> User -> IO User activate_user conn user = set_user_status conn user UserStatusActive -deactivate_user :: Connection -> User -> IO GHC.Int.Int64 +deactivate_user :: Connection -> User -> IO User deactivate_user conn user = set_user_status conn user UserStatusInActive -set_user_status :: Connection -> User -> UserStatus -> IO GHC.Int.Int64 -set_user_status conn user@User { - user_id = id - ,user_tenantid = tid - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = status} new_status = update_user conn id User { user_id = id - ,user_tenantid = tid - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = new_status } - +set_user_status :: Connection -> User -> UserStatus -> IO User +set_user_status conn user new_status = update_user conn (user_id user) user { user_status = new_status } remove_user :: Connection -> User -> IO GHC.Int.Int64 remove_user conn User {user_id = tid} = runDelete conn userTable match_function @@ -100,13 +54,10 @@ remove_user conn User {user_id = tid} = match_function User { user_id = id } = id .== constant tid read_users :: Connection -> IO [User] -read_users conn = do - runQuery conn $ user_query +read_users conn = runQuery conn user_query read_users_for_tenant :: Connection -> TenantId -> IO [User] -read_users_for_tenant conn tenant_id = do - r <- runQuery conn $ user_query_by_tenantid tenant_id - return r +read_users_for_tenant conn tenant_id = runQuery conn $ user_query_by_tenantid tenant_id read_user_by_id :: Connection -> UserId -> IO (Maybe User) read_user_by_id conn id = do From 19b697b645ff2c4b13d794e9f5f15a681ccf1569 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Sat, 5 Nov 2016 04:03:49 +0000 Subject: [PATCH 04/69] Fix issue when dealing with enum field with default value --- SpockOpaleye/src/OpaleyeDef.hs | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index c155fb7..714dc6d 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -25,7 +25,7 @@ type TenantTableW = TenantPoly (Column PGText) (Column PGText) (Column PGText) - (Column PGText) + (Maybe (Column PGText)) (Maybe (Column (Nullable PGInt4))) (Column PGText) @@ -52,7 +52,7 @@ tenantTable = Table "tenants" (pTenant tenant_lastname = (required "last_name"), tenant_email = (required "email"), tenant_phone = (required "phone"), - tenant_status = (required "status"), + tenant_status = (optional "status"), tenant_ownerid = (optional "owner_id"), tenant_backofficedomain = (required "backoffice_domain") } @@ -116,15 +116,15 @@ roleTable = Table "roles" (pRole Role { userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) -instance D.Default Constant TenantStatus (Column PGText) where +instance D.Default Constant TenantStatus (Maybe (Column PGText)) where def = Constant def' where - def' :: TenantStatus -> (Column PGText) - def' TenantStatusInActive = pgStrictText "inactive" - def' TenantStatusActive = pgStrictText "active" - def' TenantStatusNew = pgStrictText "new" + def' :: TenantStatus -> (Maybe (Column PGText)) + def' TenantStatusInActive = Just $ pgStrictText "inactive" + def' TenantStatusActive = Just $ pgStrictText "active" + def' TenantStatusNew = Just $ pgStrictText "new" -instance FromField (TenantStatus) where +instance FromField TenantStatus where fromField f mdata = return tStatus where tStatus = @@ -225,13 +225,13 @@ instance QueryRunnerColumnDefault PGInt4 UserId where queryRunnerColumnDefault = fieldQueryRunnerColumn -- -instance D.Default Constant (RoleId) (Column PGInt4) where +instance D.Default Constant RoleId (Column PGInt4) where def = Constant def' where def' :: RoleId -> (Column PGInt4) def' (RoleId id) = pgInt4 id -instance D.Default Constant (RoleId) (Maybe (Column PGInt4)) where +instance D.Default Constant RoleId (Maybe (Column PGInt4)) where def = Constant def' where def' :: RoleId -> Maybe (Column PGInt4) @@ -246,13 +246,13 @@ instance QueryRunnerColumnDefault PGInt4 RoleId where queryRunnerColumnDefault = fieldQueryRunnerColumn -- -instance D.Default Constant (TenantId) (Column PGInt4) where +instance D.Default Constant TenantId (Column PGInt4) where def = Constant def' where def' :: TenantId -> (Column PGInt4) def' (TenantId id) = pgInt4 id -instance D.Default Constant (TenantId) (Maybe (Column PGInt4)) where +instance D.Default Constant TenantId (Maybe (Column PGInt4)) where def = Constant def' where def' :: TenantId -> Maybe (Column PGInt4) @@ -271,12 +271,8 @@ instance QueryRunnerColumnDefault PGInt4 TenantId where instance D.Default Constant () (Maybe (Column PGInt4)) where def = Constant (\_ -> Nothing) -instance D.Default Constant () (Column PGText) where - def = Constant (\_ -> "") - -instance D.Default Constant () (Column (Nullable PGText)) where - def = Constant (\_ -> toNullable $ pgStrictText "") +instance D.Default Constant () (Maybe (Column PGText)) where + def = Constant (\_ -> Nothing) instance D.Default Constant Text (Column (Nullable PGText)) where def = Constant (toNullable.pgStrictText) - From f6a52f0f6a41dcfd3c91f23863c2d243ca0cf47c Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 7 Nov 2016 06:35:37 +0000 Subject: [PATCH 05/69] Add housekeeping fields to Tenant --- SpockOpaleye/src/DataTypes.hs | 11 ++++++++--- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/OpaleyeDef.hs | 20 ++++++++++++++++++++ SpockOpaleye/src/TenantApi.hs | 2 +- 4 files changed, 30 insertions(+), 5 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index ae47f24..f65be3d 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module DataTypes where @@ -6,6 +8,7 @@ import CryptoDef import Data.List.NonEmpty import Data.Text import GHC.Generics +import Data.Time(UTCTime) data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -16,8 +19,10 @@ 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 +data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant { tenant_id :: key + , tenant_createdat :: created_at + , tenant_updatedat :: updated_at , tenant_name :: name , tenant_firstname :: fname , tenant_lastname :: lname @@ -28,9 +33,9 @@ data TenantPoly key name fname lname email phone status owner_id b_domain = Tena , tenant_backofficedomain :: b_domain } deriving (Show, Generic) -type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus (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 TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked deriving (Show) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index bea6c5a..ff10ac6 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -29,7 +29,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 ()) <*> diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 714dc6d..7198509 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -11,8 +12,10 @@ import Data.Profunctor.Product import qualified Data.Profunctor.Product.Default as D import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text +import Data.Time(UTCTime) import Data.Text.Encoding import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple (Connection) import Opaleye import Control.Lens @@ -20,6 +23,8 @@ import DataTypes type TenantTableW = TenantPoly (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt (Column PGText) (Column PGText) (Column PGText) @@ -31,6 +36,8 @@ type TenantTableW = TenantPoly type TenantTableR = TenantPoly (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt (Column PGText) (Column PGText) (Column PGText) @@ -47,6 +54,8 @@ tenantTable :: Table TenantTableW TenantTableR tenantTable = Table "tenants" (pTenant Tenant { tenant_id = (optional "id"), + tenant_createdat = (optional "created_at"), + tenant_updatedat = (optional "updated_at"), tenant_name = (required "name"), tenant_firstname = (required "first_name"), tenant_lastname = (required "last_name"), @@ -276,3 +285,14 @@ instance D.Default Constant () (Maybe (Column PGText)) where instance D.Default Constant Text (Column (Nullable PGText)) where def = Constant (toNullable.pgStrictText) + +instance D.Default Constant () (Maybe (Column PGTimestamptz)) where + def = Constant (\_ -> Nothing) + +instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where + def = Constant (\time -> Just $ pgUTCTime time) + + +create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) + => Connection -> Table columnsW returned -> haskells -> IO b +create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] id diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index f9c52e0..12e425b 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -27,7 +27,7 @@ import UserApi create_tenant :: Connection -> TenantIncoming -> IO Tenant create_tenant conn tenant = do - fmap Prelude.head $ runInsertManyReturning conn tenantTable [constant tenant] id + create_item conn tenantTable tenant activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive From 46ba90a1b0ae4a1360b0549976bb7864b713ea25 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 7 Nov 2016 07:44:24 +0000 Subject: [PATCH 06/69] Add housekeeping fields to remaining models --- SpockOpaleye/src/DataTypes.hs | 36 +++++++++++++++++++--------------- SpockOpaleye/src/OpaleyeDef.hs | 25 ++++++++++++++++------- 2 files changed, 38 insertions(+), 23 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index f65be3d..413cb27 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -19,8 +19,8 @@ newtype TenantId = TenantId Int data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew deriving (Show, Generic) -data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant - { tenant_id :: key +data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant { + tenant_id :: key , tenant_createdat :: created_at , tenant_updatedat :: updated_at , tenant_name :: name @@ -31,7 +31,7 @@ data TenantPoly key created_at updated_at name fname lname email phone status ow , tenant_status :: status , tenant_ownerid :: owner_id , tenant_backofficedomain :: b_domain - } deriving (Show, Generic) +} deriving (Show, Generic) type Tenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text @@ -43,17 +43,19 @@ data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked 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 { + user_id :: key + , user_createdat :: created_at + , user_updatedat :: updated_at + , user_tenantid :: tenant_id + , user_username :: username + , user_password :: password + , user_firstname :: firstname + , user_lastname :: lastname + , user_status :: 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 data Permission = Read | Create | Update | Delete deriving (Show) @@ -61,11 +63,13 @@ data Permission = Read | Create | Update | Delete newtype RoleId = RoleId Int deriving (Show) -data RolePoly key tenant_id name permission = Role - { role_id :: key +data RolePoly key created_at updated_at tenant_id name permission = Role { + role_id :: key + , role_createdat :: created_at + , role_updatedat :: updated_at , role_tenantid :: tenant_id , role_name :: name , role_permission :: permission - } deriving (Show) +} deriving (Show) -type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) +type Role = RolePoly RoleId UTCTime UTCTime TenantId Text (NonEmpty Permission) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 7198509..89533a4 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -69,6 +69,8 @@ tenantTable = Table "tenants" (pTenant type UserTableW = UserPoly (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt (Column PGInt4) (Column PGText) (Column PGBytea) @@ -78,6 +80,8 @@ type UserTableW = UserPoly type UserTableR = UserPoly (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt (Column PGInt4) (Column PGText) (Column PGBytea) @@ -92,22 +96,28 @@ userTable :: Table UserTableW UserTableR userTable = Table "users" (pUser User { user_id = optional "id" - , user_tenantid = required "tenant_id" - , user_username = required "username" - , user_password = required "password" - , user_firstname = optional "first_name" - , user_lastname = optional "last_name" - , user_status = required "status" + , user_createdat = (optional "created_at") + , user_updatedat = (optional "updated_at") + , user_tenantid = required "tenant_id" + , user_username = required "username" + , user_password = required "password" + , user_firstname = optional "first_name" + , user_lastname = optional "last_name" + , user_status = required "status" }) type RoleTableW = RolePoly (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt (Column PGInt4) (Column PGText) (Column (PGArray PGText)) type RoleTableR = RolePoly (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt (Column PGInt4) (Column PGText) (Column (PGArray PGText)) @@ -118,6 +128,8 @@ $(makeLensesWith abbreviatedFields ''RolePoly) roleTable :: Table RoleTableW RoleTableR roleTable = Table "roles" (pRole Role { role_id = optional "id", + role_createdat = optional "created_at", + role_updatedat = optional "updated_at", role_tenantid = required "tenant_id", role_name = required "name", role_permission = required "permissions"}) @@ -292,7 +304,6 @@ instance D.Default Constant () (Maybe (Column PGTimestamptz)) where instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where def = Constant (\time -> Just $ pgUTCTime time) - create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) => Connection -> Table columnsW returned -> haskells -> IO b create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] id From e7fef1e7950bfd88edcd4d3f815f0e3f47a8b877 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 7 Nov 2016 09:21:41 +0000 Subject: [PATCH 07/69] Update housekeeping columns without lens --- SpockOpaleye/src/DataTypes.hs | 8 +++++--- SpockOpaleye/src/OpaleyeDef.hs | 22 +++++++++++----------- SpockOpaleye/src/RoleAPi.hs | 9 ++++++++- SpockOpaleye/src/TenantApi.hs | 11 +++++++---- SpockOpaleye/src/UserApi.hs | 19 ++++++++++++++----- 5 files changed, 45 insertions(+), 24 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 413cb27..476ccfe 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module DataTypes where import CryptoDef import Data.List.NonEmpty import Data.Text +import Data.Time (UTCTime) import GHC.Generics -import Data.Time(UTCTime) data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -57,6 +57,8 @@ data UserPoly key created_at updated_at tenant_id username password firstname la 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) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 89533a4..a63f038 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,10 +12,10 @@ import Data.Profunctor.Product import qualified Data.Profunctor.Product.Default as D import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text -import Data.Time(UTCTime) import Data.Text.Encoding -import Database.PostgreSQL.Simple.FromField +import Data.Time (UTCTime) import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.FromField import Opaleye import Control.Lens @@ -76,7 +76,7 @@ type UserTableW = UserPoly (Column PGBytea) (Maybe (Column (Nullable PGText))) (Maybe (Column (Nullable PGText))) - (Column PGText) + (Maybe (Column PGText)) type UserTableR = UserPoly (Column PGInt4) @@ -103,7 +103,7 @@ userTable = Table "users" (pUser , user_password = required "password" , user_firstname = optional "first_name" , user_lastname = optional "last_name" - , user_status = required "status" + , user_status = optional "status" }) type RoleTableW = RolePoly @@ -158,13 +158,13 @@ instance FromField TenantStatus where instance QueryRunnerColumnDefault PGText TenantStatus where queryRunnerColumnDefault = fieldQueryRunnerColumn -instance D.Default Constant UserStatus (Column PGText) where +instance D.Default Constant UserStatus (Maybe (Column PGText)) where def = Constant def' where - def' :: UserStatus -> (Column PGText) - def' UserStatusInActive = pgStrictText "inactive" - def' UserStatusActive = pgStrictText "active" - def' UserStatusBlocked = pgStrictText "blocked" + def' :: UserStatus -> Maybe (Column PGText) + def' UserStatusInActive = Just $ pgStrictText "inactive" + def' UserStatusActive = Just $ pgStrictText "active" + def' UserStatusBlocked = Just $ pgStrictText "blocked" instance FromField (UserStatus) where fromField f mdata = return gender @@ -304,6 +304,6 @@ instance D.Default Constant () (Maybe (Column PGTimestamptz)) where instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where def = Constant (\time -> Just $ pgUTCTime time) -create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) +create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) => Connection -> Table columnsW returned -> haskells -> IO b create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] id diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 0be02e5..5694817 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -13,6 +13,7 @@ module RoleApi import Control.Arrow import Data.List.NonEmpty import Data.Text +import Data.Time (getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -20,7 +21,13 @@ import Opaleye import OpaleyeDef create_role :: Connection -> Role -> IO Role -create_role conn role = fmap Prelude.head $ runInsertManyReturning conn roleTable [constant role] id +create_role conn role = do + current_time <- getCurrentTime + fmap Prelude.head $ runInsertManyReturning conn roleTable [constant (role { + role_createdat = current_time, + role_updatedat = current_time + }) + ] id remove_role :: Connection -> Role -> IO GHC.Int.Int64 remove_role conn Role {role_id = t_id} = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 12e425b..3b8cbce 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -17,6 +17,7 @@ module TenantApi import Control.Arrow import Data.Text +import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -27,7 +28,8 @@ import UserApi create_tenant :: Connection -> TenantIncoming -> IO Tenant create_tenant conn tenant = do - create_item conn tenantTable tenant + current_time <- getCurrentTime + create_item conn tenantTable tenant { tenant_createdat = current_time, tenant_updatedat = current_time } activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive @@ -40,13 +42,14 @@ set_tenant_status conn tenant status = update_tenant conn (tenant_id tenant) ten update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do - runUpdate conn tenantTable update_func match_func + current_time <- getCurrentTime + runUpdate conn tenantTable (update_func current_time) match_func return tenant where match_func :: TenantTableR -> Column PGBool match_func Tenant { tenant_id = id } = id .== constant t_tenantid - update_func :: TenantTableR -> TenantTableW - update_func x = constant tenant + update_func :: UTCTime -> TenantTableR -> TenantTableW + update_func current_time x = constant (tenant { tenant_updatedat = current_time }) remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 remove_tenant conn tenant@Tenant {tenant_id = tid} = do diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index b94a304..401ddfc 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -18,6 +18,7 @@ module UserApi import Control.Arrow import Data.Text +import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -26,16 +27,24 @@ import OpaleyeDef import CryptoDef -create_user :: Connection -> User -> IO User -create_user conn user = Prelude.head <$> runInsertManyReturning conn userTable [constant user] id +create_user :: Connection -> UserIncoming -> IO User +create_user conn user@ User { user_password = password } = do + Just hash <- bcryptPassword password + current_time <- getCurrentTime + Prelude.head <$> runInsertManyReturning conn userTable [constant (user { + user_createdat = current_time + , user_updatedat = current_time + , user_password = hash + } )] id update_user :: Connection -> UserId -> User -> IO User update_user conn user_id user = do - runUpdate conn userTable update_func match_func + current_time <- getCurrentTime + runUpdate conn userTable (update_func current_time) match_func return user where - update_func :: UserTableR -> UserTableW - update_func _ = constant user + update_func :: UTCTime -> UserTableR -> UserTableW + update_func current_time _ = constant (user { user_updatedat = current_time } ) match_func :: UserTableR -> Column PGBool match_func User { user_id = id } = id .== constant user_id From bc4b2df43af92c773e2ae050df1bb12641a5cf33 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 7 Nov 2016 13:26:09 +0000 Subject: [PATCH 08/69] Fix postgresql/haskell conversion issue and start using Lens --- SpockOpaleye/SpockOpaleye.cabal | 2 ++ SpockOpaleye/src/DataTypes.hs | 20 ++++++++++++-------- SpockOpaleye/src/OpaleyeDef.hs | 30 ++++++++++++++++-------------- SpockOpaleye/src/RoleAPi.hs | 17 +++++++++++------ SpockOpaleye/src/UserApi.hs | 2 +- 5 files changed, 42 insertions(+), 29 deletions(-) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 34715c8..48ce739 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -33,6 +33,7 @@ library ,text ,lens ,mtl + ,vector ,Spock >=0.11 ,aeson default-language: Haskell2010 @@ -49,6 +50,7 @@ executable SpockOpaleye-exe , lens , text , bcrypt + , vector , aeson default-language: Haskell2010 diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 476ccfe..8233164 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} module DataTypes where @@ -9,6 +10,7 @@ import Data.List.NonEmpty import Data.Text import Data.Time (UTCTime) import GHC.Generics +import Control.Lens data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -65,13 +67,15 @@ data Permission = Read | Create | Update | Delete newtype RoleId = RoleId Int deriving (Show) -data RolePoly key created_at updated_at tenant_id name permission = Role { - role_id :: key - , role_createdat :: created_at - , role_updatedat :: updated_at - , role_tenantid :: tenant_id - , role_name :: name - , role_permission :: permission +data RolePoly key tenant_id name permission created_at updated_at = Role { + _id :: key + , _tenantid :: tenant_id + , _name :: name + , _permission :: permission + , _createdat :: created_at + , _updatedat :: updated_at } deriving (Show) -type Role = RolePoly RoleId UTCTime UTCTime TenantId Text (NonEmpty Permission) +makeLenses ''RolePoly + +type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index a63f038..fbab193 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -20,6 +20,7 @@ import Opaleye import Control.Lens import DataTypes +import Data.Vector type TenantTableW = TenantPoly (Maybe (Column PGInt4)) @@ -108,31 +109,32 @@ userTable = Table "users" (pUser type RoleTableW = RolePoly (Maybe (Column PGInt4)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt (Column PGInt4) (Column PGText) (Column (PGArray PGText)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt type RoleTableR = RolePoly (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt (Column PGInt4) (Column PGText) (Column (PGArray PGText)) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt $(makeAdaptorAndInstance "pRole" ''RolePoly) $(makeLensesWith abbreviatedFields ''RolePoly) roleTable :: Table RoleTableW RoleTableR roleTable = Table "roles" (pRole Role { - role_id = optional "id", - role_createdat = optional "created_at", - role_updatedat = optional "updated_at", - role_tenantid = required "tenant_id", - role_name = required "name", - role_permission = required "permissions"}) + _id = optional "id", + _tenantid = required "tenant_id", + _name = required "name", + _permission = required "permissions", + _createdat = optional "created_at", + _updatedat = optional "updated_at" + }) userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) @@ -208,10 +210,10 @@ toPermission "Delete" = Delete toPermission _ = error "Unrecognized permission" instance FromField [Permission] where - fromField field mdata = (fmap toPermission) <$> (splitByComma <$> fromField field mdata) + fromField field mdata = fmap toPermissionList $ fromField field mdata where - splitByComma :: Text -> [Text] - splitByComma = split (\x -> x == ',') + toPermissionList :: Vector Text -> [Permission] + toPermissionList v = Data.Vector.toList $ fmap toPermission v instance FromField (NonEmpty Permission) where fromField field mdata = (fromJust.nonEmpty) <$> (fromField field mdata) @@ -306,4 +308,4 @@ instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) => Connection -> Table columnsW returned -> haskells -> IO b -create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] id +create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] Prelude.id diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 5694817..b15700e 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -20,21 +20,26 @@ import GHC.Int import Opaleye import OpaleyeDef +import Control.Lens + create_role :: Connection -> Role -> IO Role create_role conn role = do current_time <- getCurrentTime fmap Prelude.head $ runInsertManyReturning conn roleTable [constant (role { - role_createdat = current_time, - role_updatedat = current_time + _createdat = current_time, + _updatedat = current_time }) - ] id + ] Prelude.id + +update_role_name :: Role -> Role +update_role_name role = over (name) (\f -> "asdasd") role remove_role :: Connection -> Role -> IO GHC.Int.Int64 -remove_role conn Role {role_id = t_id} = do +remove_role conn Role {_id = t_id} = do runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant t_id) runDelete conn roleTable match_func where - match_func Role {role_id = id} = id .== constant t_id + match_func Role {_id = id} = id .== constant t_id read_roles_for_tenant :: Connection -> TenantId -> IO [Role] read_roles_for_tenant conn t_id = do @@ -46,6 +51,6 @@ role_query = queryTable roleTable role_query_for_tenant :: TenantId -> Query RoleTableR role_query_for_tenant t_tenantid = proc () -> - do row@ Role {role_tenantid = tenant_id } <- role_query -< () + do row@ Role {_tenantid = tenant_id } <- role_query -< () restrict -< tenant_id .== (constant t_tenantid) returnA -< row diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 401ddfc..97076ac 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -35,7 +35,7 @@ create_user conn user@ User { user_password = password } = do user_createdat = current_time , user_updatedat = current_time , user_password = hash - } )] id + } )] Prelude.id update_user :: Connection -> UserId -> User -> IO User update_user conn user_id user = do From 4e25c7c780144df7043e6dac9757a9c82a66ace1 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 7 Nov 2016 18:54:19 +0000 Subject: [PATCH 09/69] Made role api to use create_item function that uses lenses to deal with housekeeping columns --- SpockOpaleye/src/DataTypes.hs | 16 ++++++++-------- SpockOpaleye/src/OpaleyeDef.hs | 34 +++++++++++++++++++++------------- SpockOpaleye/src/RoleAPi.hs | 25 +++++++++---------------- SpockOpaleye/src/TenantApi.hs | 2 +- 4 files changed, 39 insertions(+), 38 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 8233164..f05ee1a 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -68,14 +68,14 @@ newtype RoleId = RoleId Int deriving (Show) data RolePoly key tenant_id name permission created_at updated_at = Role { - _id :: key - , _tenantid :: tenant_id - , _name :: name - , _permission :: permission - , _createdat :: created_at - , _updatedat :: updated_at + _rolepolyId :: key + , _rolepolyTenantid :: tenant_id + , _rolepolyName :: name + , _rolepolyPermission :: permission + , _rolepolyCreatedat :: created_at + , _rolepolyUpdatedat :: updated_at } deriving (Show) -makeLenses ''RolePoly - type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime + +makeFields ''RolePoly diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index fbab193..0f91546 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -3,6 +3,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} + module OpaleyeDef where @@ -13,7 +15,7 @@ import qualified Data.Profunctor.Product.Default as D import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text import Data.Text.Encoding -import Data.Time (UTCTime) +import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField import Opaleye @@ -128,12 +130,12 @@ $(makeLensesWith abbreviatedFields ''RolePoly) roleTable :: Table RoleTableW RoleTableR roleTable = Table "roles" (pRole Role { - _id = optional "id", - _tenantid = required "tenant_id", - _name = required "name", - _permission = required "permissions", - _createdat = optional "created_at", - _updatedat = optional "updated_at" + _rolepolyId = optional "id", + _rolepolyTenantid = required "tenant_id", + _rolepolyName = required "name", + _rolepolyPermission = required "permissions", + _rolepolyCreatedat = optional "created_at", + _rolepolyUpdatedat = optional "updated_at" }) userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) @@ -210,10 +212,7 @@ toPermission "Delete" = Delete toPermission _ = error "Unrecognized permission" instance FromField [Permission] where - fromField field mdata = fmap toPermissionList $ fromField field mdata - where - toPermissionList :: Vector Text -> [Permission] - toPermissionList v = Data.Vector.toList $ fmap toPermission v + fromField field mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField field mdata instance FromField (NonEmpty Permission) where fromField field mdata = (fromJust.nonEmpty) <$> (fromField field mdata) @@ -306,6 +305,15 @@ instance D.Default Constant () (Maybe (Column PGTimestamptz)) where instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where def = Constant (\time -> Just $ pgUTCTime time) -create_item :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) +create_item_1 :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) + => Connection -> Table columnsW returned -> haskells -> IO b +create_item_1 conn table item = do + fmap Prelude.head $ runInsertManyReturning conn table [constant $ item] Prelude.id + +create_item :: (HasCreatedat haskells UTCTime, HasUpdatedat haskells UTCTime, D.Default Constant haskells columnsW, D.Default QueryRunner returned b) => Connection -> Table columnsW returned -> haskells -> IO b -create_item conn table item = fmap Prelude.head $ runInsertManyReturning conn table [constant item] Prelude.id +create_item conn table item = do + current_time <- getCurrentTime + let cl = over createdat (\_ -> current_time) + let ul = over updatedat (\_ -> current_time) + fmap Prelude.head $ runInsertManyReturning conn table [constant $ (cl.ul) item] Prelude.id diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index b15700e..561fa0a 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -20,26 +20,19 @@ import GHC.Int import Opaleye import OpaleyeDef +import Prelude hiding (id) import Control.Lens create_role :: Connection -> Role -> IO Role -create_role conn role = do - current_time <- getCurrentTime - fmap Prelude.head $ runInsertManyReturning conn roleTable [constant (role { - _createdat = current_time, - _updatedat = current_time - }) - ] Prelude.id - -update_role_name :: Role -> Role -update_role_name role = over (name) (\f -> "asdasd") role +create_role conn role = create_item conn roleTable role remove_role :: Connection -> Role -> IO GHC.Int.Int64 -remove_role conn Role {_id = t_id} = do - runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant t_id) +remove_role conn role = do + runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant (view id role)) runDelete conn roleTable match_func where - match_func Role {_id = id} = id .== constant t_id + t_id = view id role + match_func role = (view id role).== constant t_id read_roles_for_tenant :: Connection -> TenantId -> IO [Role] read_roles_for_tenant conn t_id = do @@ -51,6 +44,6 @@ role_query = queryTable roleTable role_query_for_tenant :: TenantId -> Query RoleTableR role_query_for_tenant t_tenantid = proc () -> - do row@ Role {_tenantid = tenant_id } <- role_query -< () - restrict -< tenant_id .== (constant t_tenantid) - returnA -< row + do role <- role_query -< () + restrict -< (view tenantid role) .== (constant t_tenantid) + returnA -< role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 3b8cbce..9c685d4 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -29,7 +29,7 @@ import UserApi create_tenant :: Connection -> TenantIncoming -> IO Tenant create_tenant conn tenant = do current_time <- getCurrentTime - create_item conn tenantTable tenant { tenant_createdat = current_time, tenant_updatedat = current_time } + create_item_1 conn tenantTable tenant { tenant_createdat = current_time, tenant_updatedat = current_time } activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive From f11a655eca8f2361bae1edf7b3099dc3cfec4561 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 03:06:15 +0000 Subject: [PATCH 10/69] Convert more api function to use lenses --- SpockOpaleye/src/DataTypes.hs | 35 +++++++++++---------- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/OpaleyeDef.hs | 52 ++++++++++++++++--------------- SpockOpaleye/src/RoleAPi.hs | 14 ++++----- SpockOpaleye/src/TenantApi.hs | 31 +++++++++--------- SpockOpaleye/src/Validations.hs | 33 ++++++++++---------- 6 files changed, 87 insertions(+), 80 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index f05ee1a..b0f3b50 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,16 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TemplateHaskell #-} module DataTypes where +import Control.Lens import CryptoDef import Data.List.NonEmpty import Data.Text import Data.Time (UTCTime) import GHC.Generics -import Control.Lens data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -22,22 +22,24 @@ data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew deriving (Show, Generic) data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant { - tenant_id :: key - , tenant_createdat :: created_at - , tenant_updatedat :: updated_at - , 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 + _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 UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text +makeFields ''TenantPoly -type TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text +type Tenant = TenantPoly TenantId (Maybe UTCTime) (Maybe UTCTime) Text Text Text Text Text TenantStatus (Maybe UserId) Text + +type TenantIncoming = TenantPoly () (Maybe UTCTime) (Maybe UTCTime) Text Text Text Text Text () (Maybe UserId) Text data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked deriving (Show) @@ -76,6 +78,7 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { , _rolepolyUpdatedat :: updated_at } deriving (Show) -type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +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 diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index ff10ac6..208b1a7 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -29,7 +29,7 @@ instance FromJSON TenantStatus where instance FromJSON TenantIncoming where parseJSON (Object v) = - (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> + (Tenant () Nothing Nothing) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> v .: "email" <*> v .: "phone" <*> (pure ()) <*> diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 0f91546..ad01f86 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module OpaleyeDef where @@ -21,8 +21,8 @@ import Database.PostgreSQL.Simple.FromField import Opaleye import Control.Lens +import Data.Vector import DataTypes -import Data.Vector type TenantTableW = TenantPoly (Maybe (Column PGInt4)) @@ -56,17 +56,17 @@ $(makeLensesWith abbreviatedFields ''TenantPoly) tenantTable :: Table TenantTableW TenantTableR tenantTable = Table "tenants" (pTenant Tenant { - tenant_id = (optional "id"), - tenant_createdat = (optional "created_at"), - tenant_updatedat = (optional "updated_at"), - tenant_name = (required "name"), - tenant_firstname = (required "first_name"), - tenant_lastname = (required "last_name"), - tenant_email = (required "email"), - tenant_phone = (required "phone"), - tenant_status = (optional "status"), - tenant_ownerid = (optional "owner_id"), - tenant_backofficedomain = (required "backoffice_domain") + _tenantpolyId = (optional "id"), + _tenantpolyCreatedat = (optional "created_at"), + _tenantpolyUpdatedat = (optional "updated_at"), + _tenantpolyName = (required "name"), + _tenantpolyFirstname = (required "first_name"), + _tenantpolyLastname = (required "last_name"), + _tenantpolyEmail = (required "email"), + _tenantpolyPhone = (required "phone"), + _tenantpolyStatus = (optional "status"), + _tenantpolyOwnerid = (optional "owner_id"), + _tenantpolyBackofficedomain = (required "backoffice_domain") } ) @@ -305,15 +305,17 @@ instance D.Default Constant () (Maybe (Column PGTimestamptz)) where instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where def = Constant (\time -> Just $ pgUTCTime time) -create_item_1 :: (D.Default Constant haskells columnsW, D.Default QueryRunner returned b) - => Connection -> Table columnsW returned -> haskells -> IO b -create_item_1 conn table item = do - fmap Prelude.head $ runInsertManyReturning conn table [constant $ item] Prelude.id +instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where + queryRunnerColumnDefault = fieldQueryRunnerColumn -create_item :: (HasCreatedat haskells UTCTime, HasUpdatedat haskells UTCTime, D.Default Constant haskells columnsW, D.Default QueryRunner returned b) +create_item :: ( + HasCreatedat haskells (Maybe UTCTime) + , HasUpdatedat 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 = over createdat (\_ -> current_time) - let ul = over updatedat (\_ -> current_time) + let cl = createdat .~ Just current_time + let ul = updatedat .~ Just current_time fmap Prelude.head $ runInsertManyReturning conn table [constant $ (cl.ul) item] Prelude.id diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 561fa0a..bdfd6ec 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -20,19 +20,19 @@ import GHC.Int import Opaleye import OpaleyeDef -import Prelude hiding (id) -import Control.Lens +import Control.Lens +import Prelude hiding (id) -create_role :: Connection -> Role -> IO Role +create_role :: Connection -> RoleIncoming -> IO Role create_role conn role = create_item conn roleTable role remove_role :: Connection -> Role -> IO GHC.Int.Int64 remove_role conn role = do - runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant (view id role)) + runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant (role ^. id)) runDelete conn roleTable match_func where - t_id = view id role - match_func role = (view id role).== constant t_id + t_id = role ^. id + match_func role = (role ^. id).== constant t_id read_roles_for_tenant :: Connection -> TenantId -> IO [Role] read_roles_for_tenant conn t_id = do @@ -45,5 +45,5 @@ role_query_for_tenant :: TenantId -> Query RoleTableR role_query_for_tenant t_tenantid = proc () -> do role <- role_query -< () - restrict -< (view tenantid role) .== (constant t_tenantid) + restrict -< (role ^. tenantid) .== (constant t_tenantid) returnA -< role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 9c685d4..6c13eee 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -16,6 +16,7 @@ module TenantApi ) where import Control.Arrow +import Control.Lens import Data.Text import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) @@ -23,13 +24,12 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import Prelude hiding (id) import RoleApi import UserApi create_tenant :: Connection -> TenantIncoming -> IO Tenant -create_tenant conn tenant = do - current_time <- getCurrentTime - create_item_1 conn tenantTable tenant { tenant_createdat = current_time, tenant_updatedat = current_time } +create_tenant conn tenant = create_item conn tenantTable tenant activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive @@ -38,7 +38,7 @@ deactivate_tenant :: Connection -> Tenant -> IO Tenant deactivate_tenant conn tenant = set_tenant_status conn tenant TenantStatusInActive set_tenant_status :: Connection -> Tenant -> TenantStatus -> IO Tenant -set_tenant_status conn tenant status = update_tenant conn (tenant_id tenant) tenant { tenant_status = status } +set_tenant_status conn tenant st = update_tenant conn (tenant ^. id) (tenant & status .~ st) update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do @@ -47,22 +47,23 @@ update_tenant conn t_tenantid tenant = do return tenant where match_func :: TenantTableR -> Column PGBool - match_func Tenant { tenant_id = id } = id .== constant t_tenantid + match_func tenantR = (tenantR ^. id) .== constant t_tenantid update_func :: UTCTime -> TenantTableR -> TenantTableW - update_func current_time x = constant (tenant { tenant_updatedat = current_time }) + update_func current_time x = constant (tenant & updatedat .~ (Just current_time)) remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 -remove_tenant conn tenant@Tenant {tenant_id = tid} = do +remove_tenant conn tenant = do deactivate_tenant conn tenant - update_tenant conn (tenant_id tenant) tenant { tenant_ownerid = Nothing } + update_tenant conn tid (tenant & ownerid .~ Nothing) users_for_tenant <- read_users_for_tenant conn tid roles_for_tenant <- read_roles_for_tenant conn tid mapM_ (remove_role conn) roles_for_tenant mapM_ (remove_user conn) users_for_tenant runDelete conn tenantTable match_func where + tid = tenant ^. id match_func :: TenantTableR -> Column PGBool - match_func Tenant { tenant_id = id } = id .== (constant tid) + match_func Tenant { _tenantpolyId = id } = id .== (constant tid) read_tenants :: Connection -> IO [Tenant] read_tenants conn = runQuery conn tenant_query @@ -86,12 +87,12 @@ tenant_query = queryTable tenantTable tenant_query_by_id :: TenantId -> Opaleye.Query TenantTableR tenant_query_by_id t_id = proc () -> do - row@Tenant {tenant_id = id} <- tenant_query -< () - restrict -< id .== (constant t_id) - returnA -< row + tenant <- tenant_query -< () + restrict -< (tenant ^. id) .== (constant t_id) + returnA -< tenant tenant_query_by_backoffocedomain :: Text -> Opaleye.Query TenantTableR tenant_query_by_backoffocedomain domain = proc () -> do - row@Tenant { tenant_backofficedomain = bo_domain } <- tenant_query -< () - restrict -< bo_domain .== (pgStrictText domain) - returnA -< row + tenant <- tenant_query -< () + restrict -< (tenant ^. backofficedomain) .== (pgStrictText domain) + returnA -< tenant diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 991ddf3..9706ae3 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -9,19 +9,20 @@ import DataTypes import TenantApi validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult -validateIncomingTenant conn tenant@Tenant {tenant_name = name - ,tenant_firstname = fn - ,tenant_lastname = ln - ,tenant_email = em - ,tenant_phone = phone - ,tenant_backofficedomain = bo_domain} = do - unique_bod <- check_for_unique_bo_domain - return $ - if and [unique_bod, validate_name, validate_contact] - then Valid - else Invalid - where - validate_contact = and $ (>= 0) . T.length <$> [fn, ln, em, phone] - validate_name = (T.length name) >= 3 - check_for_unique_bo_domain = - isNothing <$> read_tenant_by_backofficedomain conn bo_domain +validateIncomingTenant conn tenant = return Valid +--validateIncomingTenant conn tenant@Tenant {tenant_name = name +-- ,tenant_firstname = fn +-- ,tenant_lastname = ln +-- ,tenant_email = em +-- ,tenant_phone = phone +-- ,tenant_backofficedomain = bo_domain} = do +-- unique_bod <- check_for_unique_bo_domain +-- return $ +-- if and [unique_bod, validate_name, validate_contact] +-- then Valid +-- else Invalid +-- where +-- validate_contact = and $ (>= 0) . T.length <$> [fn, ln, em, phone] +-- validate_name = (T.length name) >= 3 +-- check_for_unique_bo_domain = +-- isNothing <$> read_tenant_by_backofficedomain conn bo_domain From bb234be9c0b4b494568359325be46643d7b7db8c Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 05:12:32 +0000 Subject: [PATCH 11/69] Fix json generation --- SpockOpaleye/src/JsonInstances.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 208b1a7..59e234b 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -8,6 +8,7 @@ import Control.Monad import Data.Aeson import Data.Aeson.Types import Data.Text +import Data.Char import DataTypes instance FromJSON UserId where @@ -47,9 +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 From 785c7d74542dcbea9839ea2767fef596783e4e2d Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 08:17:53 +0000 Subject: [PATCH 12/69] Implementing generic update function --- SpockOpaleye/src/DataTypes.hs | 7 +++++++ SpockOpaleye/src/OpaleyeDef.hs | 19 ++++++++++++++++--- SpockOpaleye/src/TenantApi.hs | 19 ++++++++++++------- 3 files changed, 35 insertions(+), 10 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index b0f3b50..490f323 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -82,3 +82,10 @@ type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) (Maybe UTCTime) type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime) makeFields ''RolePoly + +class ItemId a where + getWrappedId :: a -> Int + +instance ItemId TenantId where + getWrappedId (TenantId a) = a + diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index ad01f86..080d075 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -23,6 +23,7 @@ import Opaleye import Control.Lens import Data.Vector import DataTypes +import GHC.Int type TenantTableW = TenantPoly (Maybe (Column PGInt4)) @@ -310,12 +311,24 @@ instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where create_item :: ( HasCreatedat haskells (Maybe UTCTime) - , HasUpdatedat 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 - let ul = updatedat .~ Just current_time - fmap Prelude.head $ runInsertManyReturning conn table [constant $ (cl.ul) item] Prelude.id + fmap Prelude.head $ runInsertManyReturning conn table [constant $ cl item] Prelude.id + +update_item :: ( + HasUpdatedat haskells (Maybe UTCTime) + , D.Default Constant haskells columnsW + , ItemId item_id + ) + => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO GHC.Int.Int64 +update_item conn table it_id item = do + current_time <- getCurrentTime + let cl = updatedat .~ Just current_time + runUpdate conn table (\_ -> constant $ cl item) match_func + where + match_func :: (haskells -> Column PGBool) + match_func item = pgBool True diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 6c13eee..d619cdb 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -42,14 +42,19 @@ set_tenant_status conn tenant st = update_tenant conn (tenant ^. id) (tenant & s update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do - current_time <- getCurrentTime - runUpdate conn tenantTable (update_func current_time) match_func + update_item conn tenantTable t_tenantid tenant return tenant - where - match_func :: TenantTableR -> Column PGBool - match_func tenantR = (tenantR ^. id) .== constant t_tenantid - update_func :: UTCTime -> TenantTableR -> TenantTableW - update_func current_time x = constant (tenant & updatedat .~ (Just current_time)) + +--update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant +--update_tenant conn t_tenantid tenant = do +-- current_time <- getCurrentTime +-- runUpdate conn tenantTable (update_func current_time) match_func +-- return tenant +-- where +-- match_func :: TenantTableR -> Column PGBool +-- match_func tenantR = (tenantR ^. id) .== constant t_tenantid +-- update_func :: UTCTime -> TenantTableR -> TenantTableW +-- update_func current_time x = constant (tenant & updatedat .~ (Just current_time)) remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 remove_tenant conn tenant = do From f286b54e03abb8e0db360d54e2b8205f9596aaa3 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 08:53:55 +0000 Subject: [PATCH 13/69] Generic update function type checks now --- SpockOpaleye/src/OpaleyeDef.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 080d075..8620617 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -323,6 +323,8 @@ update_item :: ( HasUpdatedat haskells (Maybe UTCTime) , D.Default Constant haskells columnsW , ItemId item_id + , HasId haskells item_id + , HasId columnsR (Column PGInt4) ) => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO GHC.Int.Int64 update_item conn table it_id item = do @@ -330,5 +332,5 @@ update_item conn table it_id item = do let cl = updatedat .~ Just current_time runUpdate conn table (\_ -> constant $ cl item) match_func where - match_func :: (haskells -> Column PGBool) - match_func item = pgBool True + match_func :: (HasId cmR (Column PGInt4)) => (cmR -> Column PGBool) + match_func item = (item ^. OpaleyeDef.id) .== (pgInt4 $ getWrappedId it_id) From 4781ca849e439e8d9e31c552bad42f8007e7f5a1 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 09:45:39 +0000 Subject: [PATCH 14/69] Refactor --- SpockOpaleye/src/DataTypes.hs | 7 ------- SpockOpaleye/src/OpaleyeDef.hs | 13 ++++++++----- SpockOpaleye/src/TenantApi.hs | 1 - 3 files changed, 8 insertions(+), 13 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 490f323..b0f3b50 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -82,10 +82,3 @@ type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) (Maybe UTCTime) type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime) makeFields ''RolePoly - -class ItemId a where - getWrappedId :: a -> Int - -instance ItemId TenantId where - getWrappedId (TenantId a) = a - diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 8620617..6132652 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -322,15 +322,18 @@ create_item conn table item = do update_item :: ( HasUpdatedat haskells (Maybe UTCTime) , D.Default Constant haskells columnsW - , ItemId item_id + , D.Default Constant item_id (Column PGInt4) , HasId haskells item_id , HasId columnsR (Column PGInt4) ) - => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO GHC.Int.Int64 + => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO haskells update_item conn table it_id item = do current_time <- getCurrentTime - let cl = updatedat .~ Just current_time - runUpdate conn table (\_ -> constant $ cl item) match_func + 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 ^. OpaleyeDef.id) .== (pgInt4 $ getWrappedId it_id) + match_func item = (item ^. OpaleyeDef.id) .== (constant it_id) diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index d619cdb..a0d70ed 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -43,7 +43,6 @@ set_tenant_status conn tenant st = update_tenant conn (tenant ^. id) (tenant & s update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do update_item conn tenantTable t_tenantid tenant - return tenant --update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant --update_tenant conn t_tenantid tenant = do From e16f7a009372c99fa385d05b50433fcc6745715b Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 8 Nov 2016 11:06:12 +0000 Subject: [PATCH 15/69] Convert everything to use lens --- SpockOpaleye/src/DataTypes.hs | 24 ++++++++++-------- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/OpaleyeDef.hs | 20 +++++++-------- SpockOpaleye/src/RoleAPi.hs | 3 +++ SpockOpaleye/src/TenantApi.hs | 13 +--------- SpockOpaleye/src/UserApi.hs | 42 ++++++++++++------------------- 6 files changed, 44 insertions(+), 60 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index b0f3b50..76e4aa1 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -48,20 +48,22 @@ newtype UserId = UserId Int deriving (Show, Generic) data UserPoly key created_at updated_at tenant_id username password firstname lastname status = User { - user_id :: key - , user_createdat :: created_at - , user_updatedat :: updated_at - , user_tenantid :: tenant_id - , user_username :: username - , user_password :: password - , user_firstname :: firstname - , user_lastname :: lastname - , user_status :: status + _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 UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus +makeFields ''UserPoly -type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) () +type User = UserPoly UserId (Maybe UTCTime) (Maybe UTCTime) TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus + +type UserIncoming = UserPoly () (Maybe UTCTime) (Maybe UTCTime) TenantId Text Text (Maybe Text) (Maybe Text) () data Permission = Read | Create | Update | Delete deriving (Show) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 59e234b..af54269 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -7,8 +7,8 @@ module JsonInstances where import Control.Monad import Data.Aeson import Data.Aeson.Types +import Data.Char import Data.Text -import Data.Char import DataTypes instance FromJSON UserId where diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 6132652..64a1b2b 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -23,7 +23,7 @@ import Opaleye import Control.Lens import Data.Vector import DataTypes -import GHC.Int +import GHC.Int type TenantTableW = TenantPoly (Maybe (Column PGInt4)) @@ -99,15 +99,15 @@ $(makeLensesWith abbreviatedFields ''UserPoly) userTable :: Table UserTableW UserTableR userTable = Table "users" (pUser User { - user_id = optional "id" - , user_createdat = (optional "created_at") - , user_updatedat = (optional "updated_at") - , user_tenantid = required "tenant_id" - , user_username = required "username" - , user_password = required "password" - , user_firstname = optional "first_name" - , user_lastname = optional "last_name" - , user_status = optional "status" + _userpolyId = optional "id" + , _userpolyCreatedat = (optional "created_at") + , _userpolyUpdatedat = (optional "updated_at") + , _userpolyTenantid = required "tenant_id" + , _userpolyUsername = required "username" + , _userpolyPassword = required "password" + , _userpolyFirstname = optional "first_name" + , _userpolyLastname = optional "last_name" + , _userpolyStatus = optional "status" }) type RoleTableW = RolePoly diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index bdfd6ec..c183c0b 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -26,6 +26,9 @@ import Prelude hiding (id) create_role :: Connection -> RoleIncoming -> IO Role create_role conn role = create_item conn roleTable role +update_role :: Connection -> RoleId -> Role -> IO Role +update_role conn role_id role = update_item conn roleTable role_id role + remove_role :: Connection -> Role -> IO GHC.Int.Int64 remove_role conn role = do runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant (role ^. id)) diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index a0d70ed..6a0409c 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -44,17 +44,6 @@ update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do update_item conn tenantTable t_tenantid tenant ---update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant ---update_tenant conn t_tenantid tenant = do --- current_time <- getCurrentTime --- runUpdate conn tenantTable (update_func current_time) match_func --- return tenant --- where --- match_func :: TenantTableR -> Column PGBool --- match_func tenantR = (tenantR ^. id) .== constant t_tenantid --- update_func :: UTCTime -> TenantTableR -> TenantTableW --- update_func current_time x = constant (tenant & updatedat .~ (Just current_time)) - remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 remove_tenant conn tenant = do deactivate_tenant conn tenant @@ -67,7 +56,7 @@ remove_tenant conn tenant = do where tid = tenant ^. id match_func :: TenantTableR -> Column PGBool - match_func Tenant { _tenantpolyId = id } = id .== (constant tid) + match_func tenant = (tenant ^. id) .== (constant tid) read_tenants :: Connection -> IO [Tenant] read_tenants conn = runQuery conn tenant_query diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 97076ac..4b20068 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -17,6 +17,7 @@ module UserApi ) where import Control.Arrow +import Control.Lens import Data.Text import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) @@ -28,25 +29,13 @@ import OpaleyeDef import CryptoDef create_user :: Connection -> UserIncoming -> IO User -create_user conn user@ User { user_password = password } = do - Just hash <- bcryptPassword password - current_time <- getCurrentTime - Prelude.head <$> runInsertManyReturning conn userTable [constant (user { - user_createdat = current_time - , user_updatedat = current_time - , user_password = hash - } )] Prelude.id +create_user conn user = do + Just hash <- bcryptPassword $ user ^. password + let full_user = user { _userpolyPassword = hash } + create_item conn userTable full_user update_user :: Connection -> UserId -> User -> IO User -update_user conn user_id user = do - current_time <- getCurrentTime - runUpdate conn userTable (update_func current_time) match_func - return user - where - update_func :: UTCTime -> UserTableR -> UserTableW - update_func current_time _ = constant (user { user_updatedat = current_time } ) - match_func :: UserTableR -> Column PGBool - match_func User { user_id = id } = id .== constant user_id +update_user conn user_id user = update_item conn userTable user_id user activate_user :: Connection -> User -> IO User activate_user conn user = set_user_status conn user UserStatusActive @@ -55,12 +44,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_id user) user { user_status = new_status } +set_user_status conn user new_status = update_user conn (user ^. OpaleyeDef.id) $ user & status .~ new_status + remove_user :: Connection -> User -> IO GHC.Int.Int64 -remove_user conn User {user_id = tid} = +remove_user conn user_t = runDelete conn userTable match_function where - match_function User { user_id = id } = id .== constant tid + match_function user = (user ^. OpaleyeDef.id).== constant (user_t ^. OpaleyeDef.id) read_users :: Connection -> IO [User] read_users conn = runQuery conn user_query @@ -88,12 +78,12 @@ user_query = queryTable userTable user_query_by_id :: UserId -> Query UserTableR user_query_by_id t_id = proc () -> do - row@User{user_id = id} <- user_query -< () - restrict -< id .== (constant t_id) - returnA -< row + user <- user_query -< () + restrict -< (user ^. OpaleyeDef.id) .== (constant t_id) + returnA -< user user_query_by_tenantid :: TenantId -> Query UserTableR user_query_by_tenantid t_tenantid = proc () -> do - row@User {user_tenantid = tenant_id} <- user_query -< () - restrict -< tenant_id .== (constant t_tenantid) - returnA -< row + user <- user_query -< () + restrict -< (user ^. tenantid) .== (constant t_tenantid) + returnA -< user From df887ed354d7fc27caef999412aa35fe7c40ac05 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 05:22:56 +0000 Subject: [PATCH 16/69] Split the generic insert/update function in a separate module --- SpockOpaleye/SpockOpaleye.cabal | 5 ++-- SpockOpaleye/src/ApiBase.hs | 46 +++++++++++++++++++++++++++++++++ SpockOpaleye/src/DataTypes.hs | 9 ++++--- SpockOpaleye/src/OpaleyeDef.hs | 33 ----------------------- SpockOpaleye/src/RoleAPi.hs | 1 + SpockOpaleye/src/TenantApi.hs | 1 + SpockOpaleye/src/UserApi.hs | 8 +++--- SpockOpaleye/src/Validations.hs | 39 ++++++++++++++-------------- 8 files changed, 81 insertions(+), 61 deletions(-) create mode 100644 SpockOpaleye/src/ApiBase.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 48ce739..76e2d9b 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -16,14 +16,15 @@ 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 diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs new file mode 100644 index 0000000..b6f482d --- /dev/null +++ b/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) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 76e4aa1..8feeaed 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} module DataTypes where @@ -35,7 +37,6 @@ data TenantPoly key created_at updated_at name fname lname email phone status ow , _tenantpolyBackofficedomain :: b_domain } deriving (Show, Generic) -makeFields ''TenantPoly type Tenant = TenantPoly TenantId (Maybe UTCTime) (Maybe UTCTime) Text Text Text Text Text TenantStatus (Maybe UserId) Text @@ -59,8 +60,6 @@ data UserPoly key created_at updated_at tenant_id username password firstname la , _userpolyStatus :: status } -makeFields ''UserPoly - type User = UserPoly UserId (Maybe UTCTime) (Maybe UTCTime) TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus type UserIncoming = UserPoly () (Maybe UTCTime) (Maybe UTCTime) TenantId Text Text (Maybe Text) (Maybe Text) () @@ -83,4 +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 +makeLensesWith abbreviatedFields ''RolePoly +makeLensesWith abbreviatedFields ''TenantPoly +makeLensesWith abbreviatedFields ''UserPoly diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 64a1b2b..9181bc4 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} - module OpaleyeDef where import Data.List.NonEmpty @@ -52,7 +51,6 @@ type TenantTableR = TenantPoly (Column PGText) $(makeAdaptorAndInstance "pTenant" ''TenantPoly) -$(makeLensesWith abbreviatedFields ''TenantPoly) tenantTable :: Table TenantTableW TenantTableR tenantTable = Table "tenants" (pTenant @@ -94,7 +92,6 @@ type UserTableR = UserPoly (Column PGText) $(makeAdaptorAndInstance "pUser" ''UserPoly) -$(makeLensesWith abbreviatedFields ''UserPoly) userTable :: Table UserTableW UserTableR userTable = Table "users" (pUser @@ -127,7 +124,6 @@ type RoleTableR = RolePoly (Column PGTimestamptz) -- updatedAt $(makeAdaptorAndInstance "pRole" ''RolePoly) -$(makeLensesWith abbreviatedFields ''RolePoly) roleTable :: Table RoleTableW RoleTableR roleTable = Table "roles" (pRole Role { @@ -308,32 +304,3 @@ instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where queryRunnerColumnDefault = fieldQueryRunnerColumn - -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 Prelude.head $ runInsertManyReturning conn table [constant $ cl item] Prelude.id - -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 ^. OpaleyeDef.id) .== (constant it_id) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index c183c0b..9ff35fe 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -20,6 +20,7 @@ import GHC.Int import Opaleye import OpaleyeDef +import ApiBase import Control.Lens import Prelude hiding (id) diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 6a0409c..e8881db 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -25,6 +25,7 @@ import GHC.Int import Opaleye import OpaleyeDef import Prelude hiding (id) +import ApiBase import RoleApi import UserApi diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 4b20068..36794bf 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -25,8 +25,10 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import ApiBase import CryptoDef +import Prelude hiding (id) create_user :: Connection -> UserIncoming -> IO User create_user conn user = do @@ -44,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 @@ -79,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 diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 9706ae3..5c777d2 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -1,28 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + module Validations where +import Control.Lens +import DataTypes import Data.Maybe import qualified Data.Text as T import Database.PostgreSQL.Simple -import DataTypes import TenantApi validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult -validateIncomingTenant conn tenant = return Valid ---validateIncomingTenant conn tenant@Tenant {tenant_name = name --- ,tenant_firstname = fn --- ,tenant_lastname = ln --- ,tenant_email = em --- ,tenant_phone = phone --- ,tenant_backofficedomain = bo_domain} = do --- unique_bod <- check_for_unique_bo_domain --- return $ --- if and [unique_bod, validate_name, validate_contact] --- then Valid --- else Invalid --- where --- validate_contact = and $ (>= 0) . T.length <$> [fn, ln, em, phone] --- validate_name = (T.length name) >= 3 --- check_for_unique_bo_domain = --- isNothing <$> read_tenant_by_backofficedomain conn bo_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 From 8308879c897c3fb10962b9b33dad27501fff74d1 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 13:08:41 +0000 Subject: [PATCH 17/69] Fixed issue --- SpockOpaleye/SpockOpaleye.cabal | 1 + SpockOpaleye/src/ApiBase.hs | 24 ++++++----- SpockOpaleye/src/DataTypes.hs | 17 +++++--- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/OpaleyeDef.hs | 65 +---------------------------- SpockOpaleye/src/OpaleyeTypes.hs | 68 +++++++++++++++++++++++++++++++ SpockOpaleye/src/RoleAPi.hs | 9 ++-- SpockOpaleye/src/TenantApi.hs | 1 + SpockOpaleye/src/UserApi.hs | 15 +++---- 9 files changed, 109 insertions(+), 93 deletions(-) create mode 100644 SpockOpaleye/src/OpaleyeTypes.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 76e2d9b..0bde333 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -29,6 +29,7 @@ library ,product-profunctors ,bytestring ,opaleye + ,time ,postgresql-simple ,bcrypt ,text diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index b6f482d..db6f9de 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module ApiBase where @@ -15,19 +16,20 @@ import Database.PostgreSQL.Simple import Opaleye import OpaleyeDef import Prelude hiding (id) +import OpaleyeTypes -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 ::( + HasCreatedat columnsW (Maybe (Column PGTimestamptz)), + HasUpdatedat columnsW (Maybe (Column PGTimestamptz)), + D.Default Constant t columnsW, D.Default QueryRunner returned b) + => Connection -> Table columnsW returned -> t -> 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) + current_time <- fmap pgUTCTime getCurrentTime + let itemPg = (constant item) & createdat .~ (Just current_time) & updatedat .~ (Just current_time) + fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) update_item :: ( - HasUpdatedat haskells (Maybe UTCTime) + HasUpdatedat haskells UTCTime , D.Default Constant haskells columnsW , D.Default Constant item_id (Column PGInt4) , HasId haskells item_id @@ -40,7 +42,7 @@ update_item conn table it_id item = do 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 + 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) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 8feeaed..2ee6db6 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} @@ -7,12 +8,15 @@ module DataTypes where +import qualified Data.Profunctor.Product.Default as D +import Opaleye import Control.Lens import CryptoDef import Data.List.NonEmpty import Data.Text import Data.Time (UTCTime) import GHC.Generics +import Data.Time (UTCTime, getCurrentTime) data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -38,9 +42,10 @@ data TenantPoly key created_at updated_at name fname lname email phone status ow } deriving (Show, Generic) -type Tenant = TenantPoly TenantId (Maybe UTCTime) (Maybe UTCTime) Text Text Text Text Text TenantStatus (Maybe UserId) Text +type Tenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text -type TenantIncoming = TenantPoly () (Maybe UTCTime) (Maybe UTCTime) Text Text Text Text Text () (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) @@ -60,9 +65,9 @@ data UserPoly key created_at updated_at tenant_id username password firstname la , _userpolyStatus :: status } -type User = UserPoly UserId (Maybe UTCTime) (Maybe UTCTime) 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 () (Maybe UTCTime) (Maybe UTCTime) TenantId Text Text (Maybe Text) (Maybe Text) () +type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) () data Permission = Read | Create | Update | Delete deriving (Show) @@ -79,8 +84,8 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { , _rolepolyUpdatedat :: updated_at } deriving (Show) -type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime) -type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) (Maybe UTCTime) (Maybe UTCTime) +type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () makeLensesWith abbreviatedFields ''RolePoly makeLensesWith abbreviatedFields ''TenantPoly diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index af54269..e4dd23e 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -30,7 +30,7 @@ instance FromJSON TenantStatus where instance FromJSON TenantIncoming where parseJSON (Object v) = - (Tenant () Nothing Nothing) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> + (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> v .: "email" <*> v .: "phone" <*> (pure ()) <*> diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 9181bc4..d512b20 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -7,6 +7,7 @@ module OpaleyeDef where +import OpaleyeTypes import Data.List.NonEmpty import Data.Maybe import Data.Profunctor.Product @@ -24,32 +25,6 @@ import Data.Vector import DataTypes import GHC.Int -type TenantTableW = TenantPoly - (Maybe (Column PGInt4)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Maybe (Column PGText)) - (Maybe (Column (Nullable PGInt4))) - (Column PGText) - -type TenantTableR = TenantPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column (Nullable PGInt4)) - (Column PGText) - $(makeAdaptorAndInstance "pTenant" ''TenantPoly) tenantTable :: Table TenantTableW TenantTableR @@ -69,28 +44,6 @@ tenantTable = Table "tenants" (pTenant } ) -type UserTableW = UserPoly - (Maybe (Column PGInt4)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Maybe (Column (Nullable PGText))) - (Maybe (Column (Nullable PGText))) - (Maybe (Column PGText)) - -type UserTableR = UserPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Column (Nullable PGText)) - (Column (Nullable PGText)) - (Column PGText) - $(makeAdaptorAndInstance "pUser" ''UserPoly) userTable :: Table UserTableW UserTableR @@ -107,22 +60,6 @@ userTable = Table "users" (pUser , _userpolyStatus = optional "status" }) -type RoleTableW = RolePoly - (Maybe (Column PGInt4)) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt - -type RoleTableR = RolePoly - (Column PGInt4) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - $(makeAdaptorAndInstance "pRole" ''RolePoly) roleTable :: Table RoleTableW RoleTableR diff --git a/SpockOpaleye/src/OpaleyeTypes.hs b/SpockOpaleye/src/OpaleyeTypes.hs new file mode 100644 index 0000000..b083ae0 --- /dev/null +++ b/SpockOpaleye/src/OpaleyeTypes.hs @@ -0,0 +1,68 @@ +module OpaleyeTypes where + +import Opaleye +import DataTypes + +type TenantTableW = TenantPoly + (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Maybe (Column PGText)) + (Maybe (Column (Nullable PGInt4))) + (Column PGText) + +type TenantTableR = TenantPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column (Nullable PGInt4)) + (Column PGText) + +type UserTableW = UserPoly + (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Maybe (Column (Nullable PGText))) + (Maybe (Column (Nullable PGText))) + (Maybe (Column PGText)) + +type UserTableR = UserPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Column (Nullable PGText)) + (Column (Nullable PGText)) + (Column PGText) + +type RoleTableW = RolePoly + (Maybe (Column PGInt4)) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Maybe (Column PGTimestamptz)) -- updatedAt + +type RoleTableR = RolePoly + (Column PGInt4) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 9ff35fe..08a67f2 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( create_role - , remove_role + ( + remove_role , read_roles_for_tenant ) where @@ -19,13 +19,14 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import OpaleyeTypes import ApiBase import Control.Lens import Prelude hiding (id) -create_role :: Connection -> RoleIncoming -> IO Role -create_role conn role = create_item conn roleTable role +--create_role :: Connection -> RoleIncoming -> IO Role +--create_role conn role = create_item conn roleTable role update_role :: Connection -> RoleId -> Role -> IO Role update_role conn role_id role = update_item conn roleTable role_id role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index e8881db..7cd0687 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -24,6 +24,7 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import OpaleyeTypes import Prelude hiding (id) import ApiBase import RoleApi diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 36794bf..2a702ec 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( create_user - , read_users + ( + read_users , read_user_by_id , read_users_for_tenant , add_role_to_user @@ -25,16 +25,17 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import OpaleyeTypes import ApiBase import CryptoDef import Prelude hiding (id) -create_user :: Connection -> UserIncoming -> IO User -create_user conn user = do - Just hash <- bcryptPassword $ user ^. password - let full_user = user { _userpolyPassword = hash } - create_item conn userTable full_user +--create_user :: Connection -> UserIncoming -> IO User +--create_user conn user = do +-- Just hash <- bcryptPassword $ user ^. password +-- let full_user = user { _userpolyPassword = hash } +-- create_item conn userTable full_user update_user :: Connection -> UserId -> User -> IO User update_user conn user_id user = update_item conn userTable user_id user From 74e87435f570991ab778c73a5c9e65d41feffb8a Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 14:56:15 +0000 Subject: [PATCH 18/69] Refactor --- SpockOpaleye/src/ApiBase.hs | 12 ++++++------ SpockOpaleye/src/RoleAPi.hs | 2 +- SpockOpaleye/src/TenantApi.hs | 4 ++-- SpockOpaleye/src/UserApi.hs | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index db6f9de..0c54865 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -18,17 +18,17 @@ import OpaleyeDef import Prelude hiding (id) import OpaleyeTypes -create_item ::( +create_row ::( HasCreatedat columnsW (Maybe (Column PGTimestamptz)), HasUpdatedat columnsW (Maybe (Column PGTimestamptz)), - D.Default Constant t columnsW, D.Default QueryRunner returned b) - => Connection -> Table columnsW returned -> t -> IO b -create_item conn table item = do + 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 .~ (Just current_time) fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) -update_item :: ( +update_row :: ( HasUpdatedat haskells UTCTime , D.Default Constant haskells columnsW , D.Default Constant item_id (Column PGInt4) @@ -36,7 +36,7 @@ update_item :: ( , HasId columnsR (Column PGInt4) ) => Connection -> Table columnsW columnsR -> item_id -> haskells -> IO haskells -update_item conn table it_id item = do +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 diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 08a67f2..e819859 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -29,7 +29,7 @@ import Prelude hiding (id) --create_role conn role = create_item conn roleTable role update_role :: Connection -> RoleId -> Role -> IO Role -update_role conn role_id role = update_item conn roleTable role_id role +update_role conn role_id role = update_row conn roleTable role_id role remove_role :: Connection -> Role -> IO GHC.Int.Int64 remove_role conn role = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 7cd0687..6a7be24 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -31,7 +31,7 @@ import RoleApi import UserApi create_tenant :: Connection -> TenantIncoming -> IO Tenant -create_tenant conn tenant = create_item conn tenantTable tenant +create_tenant conn tenant = create_row conn tenantTable tenant activate_tenant :: Connection -> Tenant -> IO Tenant activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive @@ -44,7 +44,7 @@ set_tenant_status conn tenant st = update_tenant conn (tenant ^. id) (tenant & s update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant update_tenant conn t_tenantid tenant = do - update_item conn tenantTable t_tenantid tenant + update_row conn tenantTable t_tenantid tenant remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 remove_tenant conn tenant = do diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 2a702ec..edcdbcc 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -38,7 +38,7 @@ import Prelude hiding (id) -- create_item conn userTable full_user update_user :: Connection -> UserId -> User -> IO User -update_user conn user_id user = update_item conn userTable user_id user +update_user conn user_id user = update_row conn userTable user_id user activate_user :: Connection -> User -> IO User activate_user conn user = set_user_status conn user UserStatusActive From a8c94fd25874367ddaf7a9d2a595388397426536 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 17:34:22 +0000 Subject: [PATCH 19/69] Make created fields optional and updated field required for writing --- SpockOpaleye/src/ApiBase.hs | 4 ++-- SpockOpaleye/src/OpaleyeDef.hs | 16 +++++++++++++--- SpockOpaleye/src/OpaleyeTypes.hs | 2 +- 3 files changed, 16 insertions(+), 6 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 0c54865..867ccaa 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -20,12 +20,12 @@ import OpaleyeTypes create_row ::( HasCreatedat columnsW (Maybe (Column PGTimestamptz)), - HasUpdatedat 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 .~ (Just current_time) + let itemPg = (constant item) & createdat .~ (Just current_time) & updatedat .~ (current_time) fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) update_row :: ( diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index d512b20..cb7d448 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -15,7 +15,7 @@ import qualified Data.Profunctor.Product.Default as D import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text import Data.Text.Encoding -import Data.Time (UTCTime, getCurrentTime) +import Data.Time import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField import Opaleye @@ -32,7 +32,7 @@ tenantTable = Table "tenants" (pTenant Tenant { _tenantpolyId = (optional "id"), _tenantpolyCreatedat = (optional "created_at"), - _tenantpolyUpdatedat = (optional "updated_at"), + _tenantpolyUpdatedat = (required "updated_at"), _tenantpolyName = (required "name"), _tenantpolyFirstname = (required "first_name"), _tenantpolyLastname = (required "last_name"), @@ -234,7 +234,17 @@ instance D.Default Constant Text (Column (Nullable PGText)) where def = Constant (toNullable.pgStrictText) instance D.Default Constant () (Maybe (Column PGTimestamptz)) where - def = Constant (\_ -> Nothing) + def = Constant (\() -> Nothing) + +instance D.Default Constant () (Column PGTimestamptz) where + def = Constant (\() -> pgUTCTime defaultutc) + where + defaultutc = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where def = Constant (\time -> Just $ pgUTCTime time) diff --git a/SpockOpaleye/src/OpaleyeTypes.hs b/SpockOpaleye/src/OpaleyeTypes.hs index b083ae0..16452cc 100644 --- a/SpockOpaleye/src/OpaleyeTypes.hs +++ b/SpockOpaleye/src/OpaleyeTypes.hs @@ -6,7 +6,7 @@ import DataTypes type TenantTableW = TenantPoly (Maybe (Column PGInt4)) (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt + (Column PGTimestamptz) -- updatedAt (Column PGText) (Column PGText) (Column PGText) From 74eff26a8890496a9adde8ea5f59d1491d73a330 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 17:40:18 +0000 Subject: [PATCH 20/69] Removed unused AllowAmbiguousTypes extension --- SpockOpaleye/src/ApiBase.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 867ccaa..cfb43af 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE AllowAmbiguousTypes #-} module ApiBase where From 290cc61bf5166b2a1e56eef44cdaea4483469da2 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 9 Nov 2016 17:46:40 +0000 Subject: [PATCH 21/69] Reenable create functions --- SpockOpaleye/src/ApiBase.hs | 16 ++++++++-------- SpockOpaleye/src/DataTypes.hs | 22 +++++++++++----------- SpockOpaleye/src/OpaleyeDef.hs | 8 ++++---- SpockOpaleye/src/OpaleyeTypes.hs | 8 ++++---- SpockOpaleye/src/RoleAPi.hs | 8 ++++---- SpockOpaleye/src/TenantApi.hs | 2 +- SpockOpaleye/src/UserApi.hs | 18 +++++++++--------- SpockOpaleye/src/Validations.hs | 4 ++-- 8 files changed, 43 insertions(+), 43 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index cfb43af..01cb0e2 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -7,20 +7,20 @@ module ApiBase where -import qualified Data.Profunctor.Product.Default as D -import Data.Time (UTCTime, getCurrentTime) import Control.Lens -import DataTypes +import qualified Data.Profunctor.Product.Default as D +import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple -import Opaleye -import OpaleyeDef -import Prelude hiding (id) -import OpaleyeTypes +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) + 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 diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 2ee6db6..8d63a50 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} module DataTypes where -import qualified Data.Profunctor.Product.Default as D -import Opaleye 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) +import Data.Time (UTCTime, getCurrentTime) import GHC.Generics -import Data.Time (UTCTime, getCurrentTime) +import Opaleye data ValidationResult = Valid | Invalid deriving (Eq, Show) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index cb7d448..fb0fa33 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -7,7 +7,6 @@ module OpaleyeDef where -import OpaleyeTypes import Data.List.NonEmpty import Data.Maybe import Data.Profunctor.Product @@ -15,10 +14,11 @@ import qualified Data.Profunctor.Product.Default as D import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text import Data.Text.Encoding -import Data.Time +import Data.Time import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField import Opaleye +import OpaleyeTypes import Control.Lens import Data.Vector @@ -51,7 +51,7 @@ userTable = Table "users" (pUser User { _userpolyId = optional "id" , _userpolyCreatedat = (optional "created_at") - , _userpolyUpdatedat = (optional "updated_at") + , _userpolyUpdatedat = (required "updated_at") , _userpolyTenantid = required "tenant_id" , _userpolyUsername = required "username" , _userpolyPassword = required "password" @@ -69,7 +69,7 @@ roleTable = Table "roles" (pRole Role { _rolepolyName = required "name", _rolepolyPermission = required "permissions", _rolepolyCreatedat = optional "created_at", - _rolepolyUpdatedat = optional "updated_at" + _rolepolyUpdatedat = required "updated_at" }) userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) diff --git a/SpockOpaleye/src/OpaleyeTypes.hs b/SpockOpaleye/src/OpaleyeTypes.hs index 16452cc..bfc38cf 100644 --- a/SpockOpaleye/src/OpaleyeTypes.hs +++ b/SpockOpaleye/src/OpaleyeTypes.hs @@ -1,7 +1,7 @@ module OpaleyeTypes where -import Opaleye -import DataTypes +import DataTypes +import Opaleye type TenantTableW = TenantPoly (Maybe (Column PGInt4)) @@ -32,7 +32,7 @@ type TenantTableR = TenantPoly type UserTableW = UserPoly (Maybe (Column PGInt4)) (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt + (Column PGTimestamptz) -- updatedAt (Column PGInt4) (Column PGText) (Column PGBytea) @@ -57,7 +57,7 @@ type RoleTableW = RolePoly (Column PGText) (Column (PGArray PGText)) (Maybe (Column PGTimestamptz)) -- createdAt - (Maybe (Column PGTimestamptz)) -- updatedAt + (Column PGTimestamptz) -- updatedAt type RoleTableR = RolePoly (Column PGInt4) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index e819859..bd573d8 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( - remove_role + ( create_role + , remove_role , read_roles_for_tenant ) where @@ -25,8 +25,8 @@ import ApiBase import Control.Lens import Prelude hiding (id) ---create_role :: Connection -> RoleIncoming -> IO Role ---create_role conn role = create_item conn roleTable role +create_role :: Connection -> RoleIncoming -> IO Role +create_role conn role = create_row conn roleTable role update_role :: Connection -> RoleId -> Role -> IO Role update_role conn role_id role = update_row conn roleTable role_id role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 6a7be24..ae3ca57 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -15,6 +15,7 @@ module TenantApi , deactivate_tenant ) where +import ApiBase import Control.Arrow import Control.Lens import Data.Text @@ -26,7 +27,6 @@ import Opaleye import OpaleyeDef import OpaleyeTypes import Prelude hiding (id) -import ApiBase import RoleApi import UserApi diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index edcdbcc..981a72a 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( - read_users + ( create_user + , read_users , read_user_by_id , read_users_for_tenant , add_role_to_user @@ -16,6 +16,7 @@ module UserApi , activate_user ) where +import ApiBase import Control.Arrow import Control.Lens import Data.Text @@ -26,16 +27,15 @@ import GHC.Int import Opaleye import OpaleyeDef import OpaleyeTypes -import ApiBase import CryptoDef -import Prelude hiding (id) +import Prelude hiding (id) ---create_user :: Connection -> UserIncoming -> IO User ---create_user conn user = do --- Just hash <- bcryptPassword $ user ^. password --- let full_user = user { _userpolyPassword = hash } --- create_item conn userTable full_user +create_user :: Connection -> UserIncoming -> IO User +create_user conn user = do + Just hash <- bcryptPassword $ user ^. password + let full_user = user { _userpolyPassword = hash } + create_row conn userTable full_user update_user :: Connection -> UserId -> User -> IO User update_user conn user_id user = update_row conn userTable user_id user diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 5c777d2..99c4438 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -8,11 +8,11 @@ module Validations where -import Control.Lens -import DataTypes +import Control.Lens import Data.Maybe import qualified Data.Text as T import Database.PostgreSQL.Simple +import DataTypes import TenantApi validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult From 945ef755fa11fc9ca6f34e2324badf0dcd0b01a5 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 08:21:30 +0000 Subject: [PATCH 22/69] Merge OpaleyeTypes with OpaleyeDef --- SpockOpaleye/src/ApiBase.hs | 1 - SpockOpaleye/src/OpaleyeDef.hs | 65 +++++++++++++++++++++++++++++- SpockOpaleye/src/OpaleyeTypes.hs | 68 -------------------------------- SpockOpaleye/src/RoleAPi.hs | 1 - SpockOpaleye/src/TenantApi.hs | 1 - SpockOpaleye/src/UserApi.hs | 1 - 6 files changed, 64 insertions(+), 73 deletions(-) delete mode 100644 SpockOpaleye/src/OpaleyeTypes.hs diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 01cb0e2..81da4f2 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -14,7 +14,6 @@ import Database.PostgreSQL.Simple import DataTypes import Opaleye import OpaleyeDef -import OpaleyeTypes import Prelude hiding (id) create_row ::( diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index fb0fa33..fae5f8a 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -18,13 +18,76 @@ import Data.Time import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField import Opaleye -import OpaleyeTypes import Control.Lens import Data.Vector import DataTypes import GHC.Int +type TenantTableW = TenantPoly + (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Maybe (Column PGText)) + (Maybe (Column (Nullable PGInt4))) + (Column PGText) + +type TenantTableR = TenantPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column (Nullable PGInt4)) + (Column PGText) + +type UserTableW = UserPoly + (Maybe (Column PGInt4)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Maybe (Column (Nullable PGText))) + (Maybe (Column (Nullable PGText))) + (Maybe (Column PGText)) + +type UserTableR = UserPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Column (Nullable PGText)) + (Column (Nullable PGText)) + (Column PGText) + +type RoleTableW = RolePoly + (Maybe (Column PGInt4)) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + +type RoleTableR = RolePoly + (Column PGInt4) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + $(makeAdaptorAndInstance "pTenant" ''TenantPoly) tenantTable :: Table TenantTableW TenantTableR diff --git a/SpockOpaleye/src/OpaleyeTypes.hs b/SpockOpaleye/src/OpaleyeTypes.hs deleted file mode 100644 index bfc38cf..0000000 --- a/SpockOpaleye/src/OpaleyeTypes.hs +++ /dev/null @@ -1,68 +0,0 @@ -module OpaleyeTypes where - -import DataTypes -import Opaleye - -type TenantTableW = TenantPoly - (Maybe (Column PGInt4)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Maybe (Column PGText)) - (Maybe (Column (Nullable PGInt4))) - (Column PGText) - -type TenantTableR = TenantPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column (Nullable PGInt4)) - (Column PGText) - -type UserTableW = UserPoly - (Maybe (Column PGInt4)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Maybe (Column (Nullable PGText))) - (Maybe (Column (Nullable PGText))) - (Maybe (Column PGText)) - -type UserTableR = UserPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Column (Nullable PGText)) - (Column (Nullable PGText)) - (Column PGText) - -type RoleTableW = RolePoly - (Maybe (Column PGInt4)) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - -type RoleTableR = RolePoly - (Column PGInt4) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index bd573d8..a95560f 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -19,7 +19,6 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef -import OpaleyeTypes import ApiBase import Control.Lens diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index ae3ca57..7dfa583 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -25,7 +25,6 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef -import OpaleyeTypes import Prelude hiding (id) import RoleApi import UserApi diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 981a72a..4157ec3 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -26,7 +26,6 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef -import OpaleyeTypes import CryptoDef import Prelude hiding (id) From e770e4c4f4522b50123fe3cd69c44e1d10f85341 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 11:17:58 +0000 Subject: [PATCH 23/69] Conver names to camel case and drop id from update functions --- SpockOpaleye/app/Main.hs | 12 ++-- SpockOpaleye/src/ApiBase.hs | 35 +++++------ SpockOpaleye/src/JsonInstances.hs | 24 ++++---- SpockOpaleye/src/OpaleyeDef.hs | 12 ++-- SpockOpaleye/src/RoleAPi.hs | 44 +++++++------- SpockOpaleye/src/TenantApi.hs | 94 +++++++++++++++--------------- SpockOpaleye/src/UserApi.hs | 96 +++++++++++++++---------------- SpockOpaleye/src/Validations.hs | 2 +- 8 files changed, 160 insertions(+), 159 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 9f85908..79071b3 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -33,13 +33,13 @@ main = do app :: SpockM Connection MySession MyAppState () app = do post ("tenants/new") $ - do maybe_tenant_incoming <- jsonBody - case maybe_tenant_incoming of - Just incoming_tenant -> do - result <- runQuery (\conn -> validateIncomingTenant conn incoming_tenant) + do maybeTenantIncoming <- jsonBody + case maybeTenantIncoming of + Just incomingTenant -> do + result <- runQuery (\conn -> validateIncomingTenant conn incomingTenant) case result of Valid -> do - new_tenant <- runQuery (\conn -> create_tenant conn incoming_tenant) - json new_tenant + newTenant <- runQuery (\conn -> createTenant conn incomingTenant) + json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 81da4f2..0a65d68 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -16,31 +16,32 @@ import Opaleye import OpaleyeDef import Prelude hiding (id) -create_row ::( +createRow ::( 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) +createRow conn table item = do + currentTime <- fmap pgUTCTime getCurrentTime + let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) -update_row :: ( +updateRow :: ( HasUpdatedat haskells UTCTime , D.Default Constant haskells columnsW - , D.Default Constant item_id (Column PGInt4) - , HasId haskells item_id + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId , 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 + => Connection -> Table columnsW columnsR -> haskells -> IO haskells +updateRow conn table item = do + currentTime <- getCurrentTime + let itId = item ^. id + let updatedItem = (putUpdatedTimestamp currentTime) item + runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) + return updatedItem 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) + putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item + putUpdatedTimestamp timestamp = updatedat .~ timestamp + matchFunc :: (HasId cmR (Column PGInt4), D.Default Constant itemId (Column PGInt4)) => (itemId -> cmR -> Column PGBool) + matchFunc itId item = (item ^. id) .== (constant itId) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index e4dd23e..cc3d03a 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -20,12 +20,12 @@ instance FromJSON TenantId where parseJSON invalid = typeMismatch "TenantId" invalid instance FromJSON TenantStatus where - parseJSON j@(String v) = t_status <$> (parseJSON j) + parseJSON j@(String v) = tStatus <$> (parseJSON j) where - t_status :: Text -> TenantStatus - t_status "active" = TenantStatusActive - t_status "inactive" = TenantStatusInActive - t_status "new" = TenantStatusNew + tStatus :: Text -> TenantStatus + tStatus "active" = TenantStatusActive + tStatus "inactive" = TenantStatusInActive + tStatus "new" = TenantStatusNew parseJSON invalid = typeMismatch "TenantStatus" invalid instance FromJSON TenantIncoming where @@ -39,18 +39,18 @@ instance FromJSON TenantIncoming where instance ToJSON TenantStatus where toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tg_modify } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tgModify } where - tg_modify :: String -> String - tg_modify "TenantStatusActive" = "active" - tg_modify "TenantStatusInActive" = "inactive" - tg_modify "TenantStatusNew" = "new" + tgModify :: String -> String + tgModify "TenantStatusActive" = "active" + tgModify "TenantStatusInActive" = "inactive" + tgModify "TenantStatusNew" = "new" instance ToJSON Tenant where toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).remove_prefix } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).removePrefix } where - remove_prefix = Prelude.drop 11 + removePrefix = Prelude.drop 11 instance ToJSON UserId where toJSON = genericToJSON defaultOptions diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index fae5f8a..a1bf129 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -184,13 +184,13 @@ instance D.Default Constant (NonEmpty Permission) (Column (PGArray PGText)) wher def = Constant def' where def' :: (NonEmpty Permission) -> (Column (PGArray PGText)) - def' (ph :| pl) = pgArray pgStrictText $ to_text <$> (ph : pl) + def' (ph :| pl) = pgArray pgStrictText $ toText <$> (ph : pl) where - to_text :: Permission -> Text - to_text Read = "Read" - to_text Create = "Create" - to_text Update = "Update" - to_text Delete = "Delete" + toText :: Permission -> Text + toText Read = "Read" + toText Create = "Create" + toText Update = "Update" + toText Delete = "Delete" instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where queryRunnerColumnDefault = fieldQueryRunnerColumn diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index a95560f..a696e23 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,9 +5,9 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( create_role - , remove_role - , read_roles_for_tenant + ( createRole + , removeRole + , readRolesForTenant ) where import Control.Arrow @@ -24,30 +24,30 @@ import ApiBase import Control.Lens import Prelude hiding (id) -create_role :: Connection -> RoleIncoming -> IO Role -create_role conn role = create_row conn roleTable role +createRole :: Connection -> RoleIncoming -> IO Role +createRole conn role = createRow conn roleTable role -update_role :: Connection -> RoleId -> Role -> IO Role -update_role conn role_id role = update_row conn roleTable role_id role +updateRole :: Connection -> Role -> IO Role +updateRole conn role = updateRow conn roleTable role -remove_role :: Connection -> Role -> IO GHC.Int.Int64 -remove_role conn role = do - runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant (role ^. id)) - runDelete conn roleTable match_func +removeRole :: Connection -> Role -> IO GHC.Int.Int64 +removeRole conn role = do + runDelete conn userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) + runDelete conn roleTable matchFunc where - t_id = role ^. id - match_func role = (role ^. id).== constant t_id + tId = role ^. id + matchFunc role = (role ^. id).== constant tId -read_roles_for_tenant :: Connection -> TenantId -> IO [Role] -read_roles_for_tenant conn t_id = do - runQuery conn $ role_query_for_tenant t_id +readRolesForTenant :: Connection -> TenantId -> IO [Role] +readRolesForTenant conn tId = do + runQuery conn $ roleQueryForTenant tId -role_query :: Query RoleTableR -role_query = queryTable roleTable +roleQuery :: Query RoleTableR +roleQuery = queryTable roleTable -role_query_for_tenant :: TenantId -> Query RoleTableR -role_query_for_tenant t_tenantid = +roleQueryForTenant :: TenantId -> Query RoleTableR +roleQueryForTenant tTenantid = proc () -> - do role <- role_query -< () - restrict -< (role ^. tenantid) .== (constant t_tenantid) + do role <- roleQuery -< () + restrict -< (role ^. tenantid) .== (constant tTenantid) returnA -< role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 7dfa583..db5b069 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -5,14 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} module TenantApi - ( create_tenant - , read_tenants - , read_tenant_by_id - , read_tenant_by_backofficedomain - , remove_tenant - , update_tenant - , activate_tenant - , deactivate_tenant + ( createTenant + , readTenants + , readTenantById + , readTenantByBackofficedomain + , removeTenant + , updateTenant + , activateTenant + , deactivateTenant ) where import ApiBase @@ -29,64 +29,64 @@ import Prelude hiding (id) import RoleApi import UserApi -create_tenant :: Connection -> TenantIncoming -> IO Tenant -create_tenant conn tenant = create_row conn tenantTable tenant +createTenant :: Connection -> TenantIncoming -> IO Tenant +createTenant conn tenant = createRow conn tenantTable tenant -activate_tenant :: Connection -> Tenant -> IO Tenant -activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive +activateTenant :: Connection -> Tenant -> IO Tenant +activateTenant conn tenant = setTenantStatus conn tenant TenantStatusActive -deactivate_tenant :: Connection -> Tenant -> IO Tenant -deactivate_tenant conn tenant = set_tenant_status conn tenant TenantStatusInActive +deactivateTenant :: Connection -> Tenant -> IO Tenant +deactivateTenant conn tenant = setTenantStatus conn tenant TenantStatusInActive -set_tenant_status :: Connection -> Tenant -> TenantStatus -> IO Tenant -set_tenant_status conn tenant st = update_tenant conn (tenant ^. id) (tenant & status .~ st) +setTenantStatus :: Connection -> Tenant -> TenantStatus -> IO Tenant +setTenantStatus conn tenant st = updateTenant conn (tenant & status .~ st) -update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant -update_tenant conn t_tenantid tenant = do - update_row conn tenantTable t_tenantid tenant +updateTenant :: Connection -> Tenant -> IO Tenant +updateTenant conn tenant = do + updateRow conn tenantTable tenant -remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 -remove_tenant conn tenant = do - deactivate_tenant conn tenant - update_tenant conn tid (tenant & ownerid .~ Nothing) - users_for_tenant <- read_users_for_tenant conn tid - roles_for_tenant <- read_roles_for_tenant conn tid - mapM_ (remove_role conn) roles_for_tenant - mapM_ (remove_user conn) users_for_tenant - runDelete conn tenantTable match_func +removeTenant :: Connection -> Tenant -> IO GHC.Int.Int64 +removeTenant conn tenant = do + deactivateTenant conn tenant + updateTenant conn (tenant & ownerid .~ Nothing) + usersForTenant <- readUsersForTenant conn tid + rolesForTenant <- readRolesForTenant conn tid + mapM_ (removeRole conn) rolesForTenant + mapM_ (removeUser conn) usersForTenant + runDelete conn tenantTable matchFunc where tid = tenant ^. id - match_func :: TenantTableR -> Column PGBool - match_func tenant = (tenant ^. id) .== (constant tid) + matchFunc :: TenantTableR -> Column PGBool + matchFunc tenant = (tenant ^. id) .== (constant tid) -read_tenants :: Connection -> IO [Tenant] -read_tenants conn = runQuery conn tenant_query +readTenants :: Connection -> IO [Tenant] +readTenants conn = runQuery conn tenantQuery -read_tenant_by_id :: Connection -> TenantId -> IO (Maybe Tenant) -read_tenant_by_id conn id = do - r <- runQuery conn $ (tenant_query_by_id id) +readTenantById :: Connection -> TenantId -> IO (Maybe Tenant) +readTenantById conn id = do + r <- runQuery conn $ (tenantQueryById id) return $ case r of [] -> Nothing (x:xs) -> Just x -read_tenant_by_backofficedomain :: Connection -> Text -> IO (Maybe Tenant) -read_tenant_by_backofficedomain conn domain = do - r <- runQuery conn $ (tenant_query_by_backoffocedomain domain) +readTenantByBackofficedomain :: Connection -> Text -> IO (Maybe Tenant) +readTenantByBackofficedomain conn domain = do + r <- runQuery conn $ (tenantQueryByBackoffocedomain domain) return $ case r of [] -> Nothing (x:xs) -> Just x -tenant_query :: Opaleye.Query TenantTableR -tenant_query = queryTable tenantTable +tenantQuery :: Opaleye.Query TenantTableR +tenantQuery = queryTable tenantTable -tenant_query_by_id :: TenantId -> Opaleye.Query TenantTableR -tenant_query_by_id t_id = proc () -> do - tenant <- tenant_query -< () - restrict -< (tenant ^. id) .== (constant t_id) +tenantQueryById :: TenantId -> Opaleye.Query TenantTableR +tenantQueryById tId = proc () -> do + tenant <- tenantQuery -< () + restrict -< (tenant ^. id) .== (constant tId) returnA -< tenant -tenant_query_by_backoffocedomain :: Text -> Opaleye.Query TenantTableR -tenant_query_by_backoffocedomain domain = proc () -> do - tenant <- tenant_query -< () +tenantQueryByBackoffocedomain :: Text -> Opaleye.Query TenantTableR +tenantQueryByBackoffocedomain domain = proc () -> do + tenant <- tenantQuery -< () restrict -< (tenant ^. backofficedomain) .== (pgStrictText domain) returnA -< tenant diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 4157ec3..3ae8c50 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,15 +5,15 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( create_user - , read_users - , read_user_by_id - , read_users_for_tenant - , add_role_to_user - , remove_role_from_user - , update_user - , remove_user - , activate_user + ( createUser + , readUsers + , readUserById + , readUsersForTenant + , addRoleToUser + , removeRoleFromUser + , updateUser + , removeUser + , activateUser ) where import ApiBase @@ -30,62 +30,62 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -create_user :: Connection -> UserIncoming -> IO User -create_user conn user = do +createUser :: Connection -> UserIncoming -> IO User +createUser conn user = do Just hash <- bcryptPassword $ user ^. password - let full_user = user { _userpolyPassword = hash } - create_row conn userTable full_user + let fullUser = user { _userpolyPassword = hash } + createRow conn userTable fullUser -update_user :: Connection -> UserId -> User -> IO User -update_user conn user_id user = update_row conn userTable user_id user +updateUser :: Connection -> User -> IO User +updateUser conn user = updateRow conn userTable user -activate_user :: Connection -> User -> IO User -activate_user conn user = set_user_status conn user UserStatusActive +activateUser :: Connection -> User -> IO User +activateUser conn user = setUserStatus conn user UserStatusActive -deactivate_user :: Connection -> User -> IO User -deactivate_user conn user = set_user_status conn user UserStatusInActive +deactivateUser :: Connection -> User -> IO User +deactivateUser conn user = setUserStatus conn user UserStatusInActive -set_user_status :: Connection -> User -> UserStatus -> IO User -set_user_status conn user new_status = update_user conn (user ^. id) $ user & status .~ new_status +setUserStatus :: Connection -> User -> UserStatus -> IO User +setUserStatus conn user newStatus = updateUser conn $ user & status .~ newStatus -remove_user :: Connection -> User -> IO GHC.Int.Int64 -remove_user conn user_t = - runDelete conn userTable match_function +removeUser :: Connection -> User -> IO GHC.Int.Int64 +removeUser conn rUser = + runDelete conn userTable matchFunction where - match_function user = (user ^. id).== constant (user_t ^. id) + matchFunction user = (user ^. id).== constant (rUser ^. id) -read_users :: Connection -> IO [User] -read_users conn = runQuery conn user_query +readUsers :: Connection -> IO [User] +readUsers conn = runQuery conn userQuery -read_users_for_tenant :: Connection -> TenantId -> IO [User] -read_users_for_tenant conn tenant_id = runQuery conn $ user_query_by_tenantid tenant_id +readUsersForTenant :: Connection -> TenantId -> IO [User] +readUsersForTenant conn tenantId = runQuery conn $ userQueryByTenantid tenantId -read_user_by_id :: Connection -> UserId -> IO (Maybe User) -read_user_by_id conn id = do - r <- runQuery conn $ user_query_by_id id +readUserById :: Connection -> UserId -> IO (Maybe User) +readUserById conn id = do + r <- runQuery conn $ userQueryById id return $ case r of [] -> Nothing (x:xs) -> Just x -add_role_to_user :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -add_role_to_user conn user_id role_id = - runInsertMany conn userRolePivotTable (return (constant user_id, constant role_id)) +addRoleToUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 +addRoleToUser conn userId roleId = + runInsertMany conn userRolePivotTable (return (constant userId, constant roleId)) -remove_role_from_user :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -remove_role_from_user conn t_user_id t_role_id = runDelete conn userRolePivotTable - (\(user_id, role_id) -> (user_id .== constant t_user_id) .&& (role_id .== constant t_role_id)) +removeRoleFromUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 +removeRoleFromUser conn tUserId tRoleId = runDelete conn userRolePivotTable + (\(userId, roleId) -> (userId .== constant tUserId) .&& (roleId .== constant tRoleId)) -user_query :: Query UserTableR -user_query = queryTable userTable +userQuery :: Query UserTableR +userQuery = queryTable userTable -user_query_by_id :: UserId -> Query UserTableR -user_query_by_id t_id = proc () -> do - user <- user_query -< () - restrict -< (user ^. id) .== (constant t_id) +userQueryById :: UserId -> Query UserTableR +userQueryById tId = proc () -> do + user <- userQuery -< () + restrict -< (user ^. id) .== (constant tId) returnA -< user -user_query_by_tenantid :: TenantId -> Query UserTableR -user_query_by_tenantid t_tenantid = proc () -> do - user <- user_query -< () - restrict -< (user ^. tenantid) .== (constant t_tenantid) +userQueryByTenantid :: TenantId -> Query UserTableR +userQueryByTenantid tTenantid = proc () -> do + user <- userQuery -< () + restrict -< (user ^. tenantid) .== (constant tTenantid) returnA -< user diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 99c4438..642e713 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -26,4 +26,4 @@ validateIncomingTenant conn tenant = do 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 + isNothing <$> readTenantByBackofficedomain conn domain From 04fc93d855095692a5ef918525e2597b993c046e Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 12:30:55 +0000 Subject: [PATCH 24/69] Make id fields read only and remove unused Default instances --- SpockOpaleye/SpockOpaleye.cabal | 1 + SpockOpaleye/src/JsonInstances.hs | 10 ++++---- SpockOpaleye/src/OpaleyeDef.hs | 39 ++++++++++++++----------------- SpockOpaleye/src/TenantApi.hs | 4 ++-- 4 files changed, 26 insertions(+), 28 deletions(-) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 0bde333..9257ccd 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -27,6 +27,7 @@ library Validations build-depends: base >= 4.7 && < 5 ,product-profunctors + ,profunctors ,bytestring ,opaleye ,time diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index cc3d03a..9b80b5e 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -4,7 +4,6 @@ module JsonInstances where -import Control.Monad import Data.Aeson import Data.Aeson.Types import Data.Char @@ -12,20 +11,21 @@ import Data.Text import DataTypes instance FromJSON UserId where - parseJSON j@(Number v) = UserId <$> (parseJSON j) + parseJSON j@(Number _) = UserId <$> (parseJSON j) parseJSON invalid = typeMismatch "UserId" invalid instance FromJSON TenantId where - parseJSON j@(Number v) = TenantId <$> (parseJSON j) + parseJSON j@(Number _) = TenantId <$> (parseJSON j) parseJSON invalid = typeMismatch "TenantId" invalid instance FromJSON TenantStatus where - parseJSON j@(String v) = tStatus <$> (parseJSON j) + parseJSON j@(String _) = tStatus <$> (parseJSON j) where tStatus :: Text -> TenantStatus tStatus "active" = TenantStatusActive tStatus "inactive" = TenantStatusInActive tStatus "new" = TenantStatusNew + tStatus _ = error "Unknown status name while parsing TenantStatus field" parseJSON invalid = typeMismatch "TenantStatus" invalid instance FromJSON TenantIncoming where @@ -36,6 +36,7 @@ instance FromJSON TenantIncoming where (pure ()) <*> v .: "userId" <*> v .: "backofficeDomain" + parseJSON invalid = typeMismatch "Unexpected type while paring TenantIncoming" invalid instance ToJSON TenantStatus where toJSON = genericToJSON defaultOptions @@ -45,6 +46,7 @@ instance ToJSON TenantStatus where tgModify "TenantStatusActive" = "active" tgModify "TenantStatusInActive" = "inactive" tgModify "TenantStatusNew" = "new" + tgModify _ = error "Unknown status name for tenant" instance ToJSON Tenant where toJSON = genericToJSON defaultOptions diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index a1bf129..85da992 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -23,9 +23,13 @@ import Control.Lens import Data.Vector import DataTypes import GHC.Int +import Data.Profunctor + +readOnly :: String -> TableProperties () (Column a) +readOnly = lmap (const Nothing) . optional type TenantTableW = TenantPoly - (Maybe (Column PGInt4)) + () (Maybe (Column PGTimestamptz)) -- createdAt (Column PGTimestamptz) -- updatedAt (Column PGText) @@ -51,7 +55,7 @@ type TenantTableR = TenantPoly (Column PGText) type UserTableW = UserPoly - (Maybe (Column PGInt4)) + () (Maybe (Column PGTimestamptz)) -- createdAt (Column PGTimestamptz) -- updatedAt (Column PGInt4) @@ -73,7 +77,7 @@ type UserTableR = UserPoly (Column PGText) type RoleTableW = RolePoly - (Maybe (Column PGInt4)) + () (Column PGInt4) (Column PGText) (Column (PGArray PGText)) @@ -93,7 +97,7 @@ $(makeAdaptorAndInstance "pTenant" ''TenantPoly) tenantTable :: Table TenantTableW TenantTableR tenantTable = Table "tenants" (pTenant Tenant { - _tenantpolyId = (optional "id"), + _tenantpolyId = (readOnly "id"), _tenantpolyCreatedat = (optional "created_at"), _tenantpolyUpdatedat = (required "updated_at"), _tenantpolyName = (required "name"), @@ -112,7 +116,7 @@ $(makeAdaptorAndInstance "pUser" ''UserPoly) userTable :: Table UserTableW UserTableR userTable = Table "users" (pUser User { - _userpolyId = optional "id" + _userpolyId = (readOnly "id") , _userpolyCreatedat = (optional "created_at") , _userpolyUpdatedat = (required "updated_at") , _userpolyTenantid = required "tenant_id" @@ -127,7 +131,7 @@ $(makeAdaptorAndInstance "pRole" ''RolePoly) roleTable :: Table RoleTableW RoleTableR roleTable = Table "roles" (pRole Role { - _rolepolyId = optional "id", + _rolepolyId = (readOnly "id"), _rolepolyTenantid = required "tenant_id", _rolepolyName = required "name", _rolepolyPermission = required "permissions", @@ -223,18 +227,15 @@ instance D.Default Constant (UserId) (Column PGInt4) where def' :: UserId -> (Column PGInt4) def' (UserId id) = pgInt4 id +instance D.Default Constant UserId () where + def = Constant (\_ -> ()) + instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where def = Constant def' where def' :: UserId -> (Column (Nullable PGInt4)) def' (UserId id) = (toNullable.pgInt4) id -instance D.Default Constant (UserId) (Maybe (Column PGInt4)) where - def = Constant def' - where - def' :: UserId -> Maybe (Column PGInt4) - def' (UserId id) = Just $ pgInt4 id - instance FromField UserId where fromField field mdata = do x <- fromField field mdata @@ -250,11 +251,8 @@ instance D.Default Constant RoleId (Column PGInt4) where def' :: RoleId -> (Column PGInt4) def' (RoleId id) = pgInt4 id -instance D.Default Constant RoleId (Maybe (Column PGInt4)) where - def = Constant def' - where - def' :: RoleId -> Maybe (Column PGInt4) - def' (RoleId id) = Just $ pgInt4 id +instance D.Default Constant RoleId () where + def = Constant (\_ -> ()) instance FromField RoleId where fromField field mdata = do @@ -271,11 +269,8 @@ instance D.Default Constant TenantId (Column PGInt4) where def' :: TenantId -> (Column PGInt4) def' (TenantId id) = pgInt4 id -instance D.Default Constant TenantId (Maybe (Column PGInt4)) where - def = Constant def' - where - def' :: TenantId -> Maybe (Column PGInt4) - def' (TenantId id) = Just $ pgInt4 id +instance D.Default Constant TenantId () where + def = Constant (\_ -> ()) instance FromField TenantId where fromField field mdata = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index db5b069..9978a72 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -67,14 +67,14 @@ readTenantById conn id = do r <- runQuery conn $ (tenantQueryById id) return $ case r of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x readTenantByBackofficedomain :: Connection -> Text -> IO (Maybe Tenant) readTenantByBackofficedomain conn domain = do r <- runQuery conn $ (tenantQueryByBackoffocedomain domain) return $ case r of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x tenantQuery :: Opaleye.Query TenantTableR tenantQuery = queryTable tenantTable From 93b60371e9118ac387b63c7913f9560e125eb84e Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 13:08:21 +0000 Subject: [PATCH 25/69] Fix warnings --- SpockOpaleye/src/ApiBase.hs | 5 ++--- SpockOpaleye/src/DataTypes.hs | 3 --- SpockOpaleye/src/OpaleyeDef.hs | 33 +++++++++++++++------------------ SpockOpaleye/src/RoleAPi.hs | 8 +++----- SpockOpaleye/src/TenantApi.hs | 11 +++++------ SpockOpaleye/src/UserApi.hs | 9 ++++----- 6 files changed, 29 insertions(+), 40 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 0a65d68..bdcaa0d 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -13,7 +13,6 @@ import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple import DataTypes import Opaleye -import OpaleyeDef import Prelude hiding (id) createRow ::( @@ -38,10 +37,10 @@ updateRow conn table item = do currentTime <- getCurrentTime let itId = item ^. id let updatedItem = (putUpdatedTimestamp currentTime) item - runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) + _ <- runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) return updatedItem where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp matchFunc :: (HasId cmR (Column PGInt4), D.Default Constant itemId (Column PGInt4)) => (itemId -> cmR -> Column PGBool) - matchFunc itId item = (item ^. id) .== (constant itId) + matchFunc itId item' = (item' ^. id) .== (constant itId) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 8d63a50..2329536 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -11,12 +11,9 @@ 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) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 85da992..057d343 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -15,15 +15,12 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Text import Data.Text.Encoding import Data.Time -import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField import Opaleye import Control.Lens import Data.Vector import DataTypes -import GHC.Int -import Data.Profunctor readOnly :: String -> TableProperties () (Column a) readOnly = lmap (const Nothing) . optional @@ -151,7 +148,7 @@ instance D.Default Constant TenantStatus (Maybe (Column PGText)) where def' TenantStatusNew = Just $ pgStrictText "new" instance FromField TenantStatus where - fromField f mdata = return tStatus + fromField _ mdata = return tStatus where tStatus = case mdata of @@ -172,7 +169,7 @@ instance D.Default Constant UserStatus (Maybe (Column PGText)) where def' UserStatusBlocked = Just $ pgStrictText "blocked" instance FromField (UserStatus) where - fromField f mdata = return gender + fromField _ mdata = return gender where gender = case mdata of @@ -200,7 +197,7 @@ instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where queryRunnerColumnDefault = fieldQueryRunnerColumn instance FromField Permission where - fromField f mdata = return $ makePermission mdata + fromField _ mdata = return $ makePermission mdata where makePermission (Just x) = toPermission $ decodeUtf8 x makePermission Nothing = error "No data read from db" @@ -213,10 +210,10 @@ toPermission "Delete" = Delete toPermission _ = error "Unrecognized permission" instance FromField [Permission] where - fromField field mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField field mdata + fromField f mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField f mdata instance FromField (NonEmpty Permission) where - fromField field mdata = (fromJust.nonEmpty) <$> (fromField field mdata) + fromField f mdata = (fromJust.nonEmpty) <$> (fromField f mdata) instance QueryRunnerColumnDefault PGText Permission where queryRunnerColumnDefault = fieldQueryRunnerColumn @@ -225,7 +222,7 @@ instance D.Default Constant (UserId) (Column PGInt4) where def = Constant def' where def' :: UserId -> (Column PGInt4) - def' (UserId id) = pgInt4 id + def' (UserId id') = pgInt4 id' instance D.Default Constant UserId () where def = Constant (\_ -> ()) @@ -234,11 +231,11 @@ instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where def = Constant def' where def' :: UserId -> (Column (Nullable PGInt4)) - def' (UserId id) = (toNullable.pgInt4) id + def' (UserId id') = (toNullable.pgInt4) id' instance FromField UserId where - fromField field mdata = do - x <- fromField field mdata + fromField f mdata = do + x <- fromField f mdata return $ UserId x instance QueryRunnerColumnDefault PGInt4 UserId where @@ -249,14 +246,14 @@ instance D.Default Constant RoleId (Column PGInt4) where def = Constant def' where def' :: RoleId -> (Column PGInt4) - def' (RoleId id) = pgInt4 id + def' (RoleId id') = pgInt4 id' instance D.Default Constant RoleId () where def = Constant (\_ -> ()) instance FromField RoleId where - fromField field mdata = do - x <- fromField field mdata + fromField f mdata = do + x <- fromField f mdata return $ RoleId x instance QueryRunnerColumnDefault PGInt4 RoleId where @@ -267,14 +264,14 @@ instance D.Default Constant TenantId (Column PGInt4) where def = Constant def' where def' :: TenantId -> (Column PGInt4) - def' (TenantId id) = pgInt4 id + def' (TenantId id') = pgInt4 id' instance D.Default Constant TenantId () where def = Constant (\_ -> ()) instance FromField TenantId where - fromField field mdata = do - x <- fromField field mdata + fromField f mdata = do + x <- fromField f mdata return $ TenantId x instance QueryRunnerColumnDefault PGInt4 TenantId where diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index a696e23..f9d22db 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -7,13 +7,11 @@ module RoleApi ( createRole , removeRole + , updateRole , readRolesForTenant ) where import Control.Arrow -import Data.List.NonEmpty -import Data.Text -import Data.Time (getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -32,11 +30,11 @@ updateRole conn role = updateRow conn roleTable role removeRole :: Connection -> Role -> IO GHC.Int.Int64 removeRole conn role = do - runDelete conn userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) + _ <- runDelete conn userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) runDelete conn roleTable matchFunc where tId = role ^. id - matchFunc role = (role ^. id).== constant tId + matchFunc role' = (role' ^. id).== constant tId readRolesForTenant :: Connection -> TenantId -> IO [Role] readRolesForTenant conn tId = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 9978a72..216c330 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -19,7 +19,6 @@ import ApiBase import Control.Arrow import Control.Lens import Data.Text -import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -47,8 +46,8 @@ updateTenant conn tenant = do removeTenant :: Connection -> Tenant -> IO GHC.Int.Int64 removeTenant conn tenant = do - deactivateTenant conn tenant - updateTenant conn (tenant & ownerid .~ Nothing) + tenant_deac <- deactivateTenant conn tenant + _ <- updateTenant conn (tenant_deac & ownerid .~ Nothing) usersForTenant <- readUsersForTenant conn tid rolesForTenant <- readRolesForTenant conn tid mapM_ (removeRole conn) rolesForTenant @@ -57,14 +56,14 @@ removeTenant conn tenant = do where tid = tenant ^. id matchFunc :: TenantTableR -> Column PGBool - matchFunc tenant = (tenant ^. id) .== (constant tid) + matchFunc tenant' = (tenant' ^. id) .== (constant tid) readTenants :: Connection -> IO [Tenant] readTenants conn = runQuery conn tenantQuery readTenantById :: Connection -> TenantId -> IO (Maybe Tenant) -readTenantById conn id = do - r <- runQuery conn $ (tenantQueryById id) +readTenantById conn tenantId = do + r <- runQuery conn $ (tenantQueryById tenantId) return $ case r of [] -> Nothing (x:_) -> Just x diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 3ae8c50..e33eade 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -14,13 +14,12 @@ module UserApi , updateUser , removeUser , activateUser + , deactivateUser ) where import ApiBase import Control.Arrow import Control.Lens -import Data.Text -import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -61,11 +60,11 @@ readUsersForTenant :: Connection -> TenantId -> IO [User] readUsersForTenant conn tenantId = runQuery conn $ userQueryByTenantid tenantId readUserById :: Connection -> UserId -> IO (Maybe User) -readUserById conn id = do - r <- runQuery conn $ userQueryById id +readUserById conn id' = do + r <- runQuery conn $ userQueryById id' return $ case r of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x addRoleToUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 addRoleToUser conn userId roleId = From 3734c4115bf49553e342b3677e7626daa9db6aec Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 13:20:02 +0000 Subject: [PATCH 26/69] Stylize --- SpockOpaleye/src/DataTypes.hs | 2 +- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/TenantApi.hs | 4 ++-- SpockOpaleye/src/UserApi.hs | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 2329536..5876d42 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -12,7 +12,7 @@ import Control.Lens import CryptoDef import Data.List.NonEmpty import Data.Text -import Data.Time (UTCTime) +import Data.Time (UTCTime) import GHC.Generics data ValidationResult = Valid | Invalid diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 9b80b5e..af86a8d 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -46,7 +46,7 @@ instance ToJSON TenantStatus where tgModify "TenantStatusActive" = "active" tgModify "TenantStatusInActive" = "inactive" tgModify "TenantStatusNew" = "new" - tgModify _ = error "Unknown status name for tenant" + tgModify _ = error "Unknown status name for tenant" instance ToJSON Tenant where toJSON = genericToJSON defaultOptions diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 216c330..4bd1737 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -65,14 +65,14 @@ readTenantById :: Connection -> TenantId -> IO (Maybe Tenant) readTenantById conn tenantId = do r <- runQuery conn $ (tenantQueryById tenantId) return $ case r of - [] -> Nothing + [] -> Nothing (x:_) -> Just x readTenantByBackofficedomain :: Connection -> Text -> IO (Maybe Tenant) readTenantByBackofficedomain conn domain = do r <- runQuery conn $ (tenantQueryByBackoffocedomain domain) return $ case r of - [] -> Nothing + [] -> Nothing (x:_) -> Just x tenantQuery :: Opaleye.Query TenantTableR diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index e33eade..0e0e7b3 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -63,7 +63,7 @@ readUserById :: Connection -> UserId -> IO (Maybe User) readUserById conn id' = do r <- runQuery conn $ userQueryById id' return $ case r of - [] -> Nothing + [] -> Nothing (x:_) -> Just x addRoleToUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 From 07304e804bbcf77f727af69f75efa743b168cc1f Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 10 Nov 2016 13:50:49 +0000 Subject: [PATCH 27/69] Refactor to use listToMaybe functions --- SpockOpaleye/src/TenantApi.hs | 11 +++-------- SpockOpaleye/src/UserApi.hs | 6 ++---- 2 files changed, 5 insertions(+), 12 deletions(-) diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 4bd1737..680fa63 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -19,6 +19,7 @@ import ApiBase import Control.Arrow import Control.Lens import Data.Text +import Data.Maybe import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -63,17 +64,11 @@ readTenants conn = runQuery conn tenantQuery readTenantById :: Connection -> TenantId -> IO (Maybe Tenant) readTenantById conn tenantId = do - r <- runQuery conn $ (tenantQueryById tenantId) - return $ case r of - [] -> Nothing - (x:_) -> Just x + listToMaybe <$> (runQuery conn $ (tenantQueryById tenantId)) readTenantByBackofficedomain :: Connection -> Text -> IO (Maybe Tenant) readTenantByBackofficedomain conn domain = do - r <- runQuery conn $ (tenantQueryByBackoffocedomain domain) - return $ case r of - [] -> Nothing - (x:_) -> Just x + listToMaybe <$> (runQuery conn $ (tenantQueryByBackoffocedomain domain)) tenantQuery :: Opaleye.Query TenantTableR tenantQuery = queryTable tenantTable diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 0e0e7b3..a5493ba 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -22,6 +22,7 @@ import Control.Arrow import Control.Lens import Database.PostgreSQL.Simple (Connection) import DataTypes +import Data.Maybe import GHC.Int import Opaleye import OpaleyeDef @@ -61,10 +62,7 @@ readUsersForTenant conn tenantId = runQuery conn $ userQueryByTenantid tenantId readUserById :: Connection -> UserId -> IO (Maybe User) readUserById conn id' = do - r <- runQuery conn $ userQueryById id' - return $ case r of - [] -> Nothing - (x:_) -> Just x + listToMaybe <$> (runQuery conn $ userQueryById id') addRoleToUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 addRoleToUser conn userId roleId = From 1a298cb7d9db9098211100dfb2f165e27c936566 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Sat, 12 Nov 2016 10:26:09 +0000 Subject: [PATCH 28/69] Start of Audtable api implementation --- SpockOpaleye/app/Main.hs | 4 +--- SpockOpaleye/src/ApiBase.hs | 18 ++++++++++++++---- SpockOpaleye/src/RoleAPi.hs | 8 ++++---- SpockOpaleye/src/TenantApi.hs | 11 +++++++---- SpockOpaleye/src/UserApi.hs | 14 +++++++------- 5 files changed, 33 insertions(+), 22 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 79071b3..a6980db 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -38,8 +38,6 @@ app = do Just incomingTenant -> do result <- runQuery (\conn -> validateIncomingTenant conn incomingTenant) case result of - Valid -> do - newTenant <- runQuery (\conn -> createTenant conn incomingTenant) - json newTenant + Valid -> json $ T.pack "Validation fail" _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index bdcaa0d..4f2ae90 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -14,16 +14,26 @@ import Database.PostgreSQL.Simple import DataTypes import Opaleye import Prelude hiding (id) +import Control.Monad.Writer +import Control.Monad.Reader + +type AuditM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a + +auditLog :: String -> AuditM () +auditLog msg = tell msg createRow ::( + Show incoming, 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 + => Connection -> Table columnsW returned -> incoming -> AuditM row createRow conn table item = do - currentTime <- fmap pgUTCTime getCurrentTime - let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) - fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) + auditLog $ "Create : " ++ (show item) + liftIO $ do + currentTime <- fmap pgUTCTime getCurrentTime + let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) + fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) updateRow :: ( HasUpdatedat haskells UTCTime diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index f9d22db..6088360 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( createRole - , removeRole + ( + removeRole , updateRole , readRolesForTenant ) where @@ -22,8 +22,8 @@ import ApiBase import Control.Lens import Prelude hiding (id) -createRole :: Connection -> RoleIncoming -> IO Role -createRole conn role = createRow conn roleTable role +--createRole :: Connection -> RoleIncoming -> IO Role +--createRole conn role = createRow conn roleTable role updateRole :: Connection -> Role -> IO Role updateRole conn role = updateRow conn roleTable role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 680fa63..a8db18f 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module TenantApi - ( createTenant - , readTenants + ( + readTenants , readTenantById , readTenantByBackofficedomain , removeTenant @@ -28,9 +28,12 @@ import OpaleyeDef import Prelude hiding (id) import RoleApi import UserApi +import Control.Monad.Writer +import Control.Monad.Reader -createTenant :: Connection -> TenantIncoming -> IO Tenant -createTenant conn tenant = createRow conn tenantTable tenant +createTenant :: Connection -> TenantIncoming -> AuditM Tenant +createTenant conn tenant = do + createRow conn tenantTable tenant activateTenant :: Connection -> Tenant -> IO Tenant activateTenant conn tenant = setTenantStatus conn tenant TenantStatusActive diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index a5493ba..274457b 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( createUser - , readUsers + ( + readUsers , readUserById , readUsersForTenant , addRoleToUser @@ -30,11 +30,11 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -createUser :: Connection -> UserIncoming -> IO User -createUser conn user = do - Just hash <- bcryptPassword $ user ^. password - let fullUser = user { _userpolyPassword = hash } - createRow conn userTable fullUser +--createUser :: Connection -> UserIncoming -> IO User +--createUser conn user = do +-- Just hash <- bcryptPassword $ user ^. password +-- let fullUser = user { _userpolyPassword = hash } +-- createRow conn userTable fullUser updateUser :: Connection -> User -> IO User updateUser conn user = updateRow conn userTable user From dd2d97110439999e48731dfbecaa9d2d1d62cfcc Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Sat, 12 Nov 2016 12:00:51 +0000 Subject: [PATCH 29/69] Convert all api function to use AuditM --- SpockOpaleye/app/Main.hs | 12 +++++++++++- SpockOpaleye/src/ApiBase.hs | 6 +++--- SpockOpaleye/src/DataTypes.hs | 9 +++++++-- SpockOpaleye/src/RoleAPi.hs | 8 ++++---- SpockOpaleye/src/TenantApi.hs | 10 +++++----- SpockOpaleye/src/UserApi.hs | 17 +++++++++-------- 6 files changed, 39 insertions(+), 23 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index a6980db..eb29f43 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -11,6 +11,8 @@ import Validations import Web.Spock import Web.Spock.Config +import Control.Monad.Reader +import Control.Monad.Writer import qualified Data.Text as T data MySession = @@ -30,6 +32,12 @@ main = do DummyAppState runSpock 8080 (spock spockCfg app) +runAuditM :: Connection -> AuditM a -> IO a +runAuditM conn x = do + (item, log) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) + return item + + app :: SpockM Connection MySession MyAppState () app = do post ("tenants/new") $ @@ -38,6 +46,8 @@ app = do Just incomingTenant -> do result <- runQuery (\conn -> validateIncomingTenant conn incomingTenant) case result of - Valid -> json $ T.pack "Validation fail" + Valid -> do + newTenant <- runQuery (\conn -> runAuditM conn $ createTenant conn incomingTenant) + json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 4f2ae90..576404b 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -8,16 +8,16 @@ module ApiBase where import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Writer import qualified Data.Profunctor.Product.Default as D import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple import DataTypes import Opaleye import Prelude hiding (id) -import Control.Monad.Writer -import Control.Monad.Reader -type AuditM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a auditLog :: String -> AuditM () auditLog msg = tell msg diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 5876d42..f9e7456 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -9,12 +9,17 @@ module DataTypes where import Control.Lens +import Control.Monad.Reader +import Control.Monad.Writer import CryptoDef import Data.List.NonEmpty import Data.Text -import Data.Time (UTCTime) +import Data.Time (UTCTime) +import Database.PostgreSQL.Simple import GHC.Generics +type AuditM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a + data ValidationResult = Valid | Invalid deriving (Eq, Show) @@ -60,7 +65,7 @@ data UserPoly key created_at updated_at tenant_id username password firstname la , _userpolyFirstname :: firstname , _userpolyLastname :: lastname , _userpolyStatus :: status -} +} deriving (Show) type User = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 6088360..25f90ec 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( - removeRole + ( createRole + , removeRole , updateRole , readRolesForTenant ) where @@ -22,8 +22,8 @@ import ApiBase import Control.Lens import Prelude hiding (id) ---createRole :: Connection -> RoleIncoming -> IO Role ---createRole conn role = createRow conn roleTable role +createRole :: Connection -> RoleIncoming -> AuditM Role +createRole conn role = createRow conn roleTable role updateRole :: Connection -> Role -> IO Role updateRole conn role = updateRow conn roleTable role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index a8db18f..03db116 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module TenantApi - ( - readTenants + ( createTenant + , readTenants , readTenantById , readTenantByBackofficedomain , removeTenant @@ -18,8 +18,10 @@ module TenantApi import ApiBase import Control.Arrow import Control.Lens -import Data.Text +import Control.Monad.Reader +import Control.Monad.Writer import Data.Maybe +import Data.Text import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int @@ -28,8 +30,6 @@ import OpaleyeDef import Prelude hiding (id) import RoleApi import UserApi -import Control.Monad.Writer -import Control.Monad.Reader createTenant :: Connection -> TenantIncoming -> AuditM Tenant createTenant conn tenant = do diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 274457b..b732601 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,8 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( - readUsers + ( createUser + , readUsers , readUserById , readUsersForTenant , addRoleToUser @@ -20,9 +20,10 @@ module UserApi import ApiBase import Control.Arrow import Control.Lens +import Control.Monad.IO.Class +import Data.Maybe import Database.PostgreSQL.Simple (Connection) import DataTypes -import Data.Maybe import GHC.Int import Opaleye import OpaleyeDef @@ -30,11 +31,11 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) ---createUser :: Connection -> UserIncoming -> IO User ---createUser conn user = do --- Just hash <- bcryptPassword $ user ^. password --- let fullUser = user { _userpolyPassword = hash } --- createRow conn userTable fullUser +createUser :: Connection -> UserIncoming -> AuditM User +createUser conn user = do + Just hash <- liftIO $ bcryptPassword $ user ^. password + let fullUser = user { _userpolyPassword = hash } + createRow conn userTable fullUser updateUser :: Connection -> User -> IO User updateUser conn user = updateRow conn userTable user From bd209c5b470e022efb0097a1e48bdfca766d4c3e Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Sat, 12 Nov 2016 17:56:38 +0000 Subject: [PATCH 30/69] Add wrapper to opaleye functions that runs in AuditM --- SpockOpaleye/app/Main.hs | 3 ++- SpockOpaleye/src/ApiBase.hs | 49 +++++++++++++++++++++++++++-------- SpockOpaleye/src/RoleAPi.hs | 2 +- SpockOpaleye/src/TenantApi.hs | 22 ++++++++-------- SpockOpaleye/src/UserApi.hs | 8 +++--- 5 files changed, 56 insertions(+), 28 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index eb29f43..bda567f 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -34,7 +34,8 @@ main = do runAuditM :: Connection -> AuditM a -> IO a runAuditM conn x = do - (item, log) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) + (item, lg) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) + putStrLn lg return item diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 576404b..0a2d4bd 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -16,41 +16,68 @@ import Data.Time (UTCTime, getCurrentTime) import Database.PostgreSQL.Simple import DataTypes import Opaleye +import GHC.Int import Prelude hiding (id) auditLog :: String -> AuditM () auditLog msg = tell msg +createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) + => Connection -> Table columnsW columnsR -> [columnsW] -> AuditM [haskells] +createDbRows conn table pgrows = do + auditLog $ "Create : " ++ (show pgrows) + liftIO $ runInsertManyReturning conn table pgrows (\x -> x) + + createRow ::( Show incoming, + Show columnsW, HasCreatedat columnsW (Maybe (Column PGTimestamptz)), HasUpdatedat columnsW (Column PGTimestamptz), D.Default Constant incoming columnsW, D.Default QueryRunner returned row) => Connection -> Table columnsW returned -> incoming -> AuditM row createRow conn table item = do - auditLog $ "Create : " ++ (show item) - liftIO $ do - currentTime <- fmap pgUTCTime getCurrentTime - let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) - fmap head $ runInsertManyReturning conn table [itemPg] (\x -> x) + currentTime <- liftIO $ fmap pgUTCTime getCurrentTime + let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) + fmap head $ createDbRows conn table [itemPg] updateRow :: ( + Show haskells, HasUpdatedat haskells UTCTime , D.Default Constant haskells columnsW , D.Default Constant itemId (Column PGInt4) , HasId haskells itemId , HasId columnsR (Column PGInt4) ) - => Connection -> Table columnsW columnsR -> haskells -> IO haskells + => Connection -> Table columnsW columnsR -> haskells -> AuditM haskells updateRow conn table item = do - currentTime <- getCurrentTime - let itId = item ^. id - let updatedItem = (putUpdatedTimestamp currentTime) item - _ <- runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) - return updatedItem + auditLog $ "Update : " ++ (show item) + liftIO $ do + currentTime <- getCurrentTime + let itId = item ^. id + let updatedItem = (putUpdatedTimestamp currentTime) item + _ <- runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) + return updatedItem where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp matchFunc :: (HasId cmR (Column PGInt4), D.Default Constant itemId (Column PGInt4)) => (itemId -> cmR -> Column PGBool) matchFunc itId item' = (item' ^. id) .== (constant itId) + +removeRow :: ( + Show haskells + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId + , HasId columnsR (Column PGInt4) + ) => Connection -> Table columnsW columnsR -> haskells -> AuditM GHC.Int.Int64 +removeRow conn table item = do + auditLog $ "Remove : " ++ (show item) + liftIO $ do + runDelete conn table $ matchFunc $ item ^. id + where + matchFunc :: ( + HasId columnsR (Column PGInt4), + D.Default Constant itemId (Column PGInt4) + ) => (itemId -> columnsR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== (constant itId) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 25f90ec..c3da9af 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -25,7 +25,7 @@ import Prelude hiding (id) createRole :: Connection -> RoleIncoming -> AuditM Role createRole conn role = createRow conn roleTable role -updateRole :: Connection -> Role -> IO Role +updateRole :: Connection -> Role -> AuditM Role updateRole conn role = updateRow conn roleTable role removeRole :: Connection -> Role -> IO GHC.Int.Int64 diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 03db116..a45b602 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -19,7 +19,6 @@ import ApiBase import Control.Arrow import Control.Lens import Control.Monad.Reader -import Control.Monad.Writer import Data.Maybe import Data.Text import Database.PostgreSQL.Simple (Connection) @@ -35,28 +34,29 @@ createTenant :: Connection -> TenantIncoming -> AuditM Tenant createTenant conn tenant = do createRow conn tenantTable tenant -activateTenant :: Connection -> Tenant -> IO Tenant +activateTenant :: Connection -> Tenant -> AuditM Tenant activateTenant conn tenant = setTenantStatus conn tenant TenantStatusActive -deactivateTenant :: Connection -> Tenant -> IO Tenant +deactivateTenant :: Connection -> Tenant -> AuditM Tenant deactivateTenant conn tenant = setTenantStatus conn tenant TenantStatusInActive -setTenantStatus :: Connection -> Tenant -> TenantStatus -> IO Tenant +setTenantStatus :: Connection -> Tenant -> TenantStatus -> AuditM Tenant setTenantStatus conn tenant st = updateTenant conn (tenant & status .~ st) -updateTenant :: Connection -> Tenant -> IO Tenant +updateTenant :: Connection -> Tenant -> AuditM Tenant updateTenant conn tenant = do updateRow conn tenantTable tenant -removeTenant :: Connection -> Tenant -> IO GHC.Int.Int64 +removeTenant :: Connection -> Tenant -> AuditM GHC.Int.Int64 removeTenant conn tenant = do tenant_deac <- deactivateTenant conn tenant _ <- updateTenant conn (tenant_deac & ownerid .~ Nothing) - usersForTenant <- readUsersForTenant conn tid - rolesForTenant <- readRolesForTenant conn tid - mapM_ (removeRole conn) rolesForTenant - mapM_ (removeUser conn) usersForTenant - runDelete conn tenantTable matchFunc + liftIO $ do + usersForTenant <- readUsersForTenant conn tid + rolesForTenant <- readRolesForTenant conn tid + mapM_ (removeRole conn) rolesForTenant + mapM_ (removeUser conn) usersForTenant + runDelete conn tenantTable matchFunc where tid = tenant ^. id matchFunc :: TenantTableR -> Column PGBool diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index b732601..1621143 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -37,16 +37,16 @@ createUser conn user = do let fullUser = user { _userpolyPassword = hash } createRow conn userTable fullUser -updateUser :: Connection -> User -> IO User +updateUser :: Connection -> User -> AuditM User updateUser conn user = updateRow conn userTable user -activateUser :: Connection -> User -> IO User +activateUser :: Connection -> User -> AuditM User activateUser conn user = setUserStatus conn user UserStatusActive -deactivateUser :: Connection -> User -> IO User +deactivateUser :: Connection -> User -> AuditM User deactivateUser conn user = setUserStatus conn user UserStatusInActive -setUserStatus :: Connection -> User -> UserStatus -> IO User +setUserStatus :: Connection -> User -> UserStatus -> AuditM User setUserStatus conn user newStatus = updateUser conn $ user & status .~ newStatus removeUser :: Connection -> User -> IO GHC.Int.Int64 From 1004ca129fddf00ad5ac16ffb82e63794e721567 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 14 Nov 2016 09:50:21 +0000 Subject: [PATCH 31/69] Add functions that does raw db updates in AuditM --- SpockOpaleye/src/ApiBase.hs | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 0a2d4bd..74689ab 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -21,15 +21,23 @@ import Prelude hiding (id) auditLog :: String -> AuditM () -auditLog msg = tell msg +auditLog = tell createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) => Connection -> Table columnsW columnsR -> [columnsW] -> AuditM [haskells] createDbRows conn table pgrows = do auditLog $ "Create : " ++ (show pgrows) liftIO $ runInsertManyReturning conn table pgrows (\x -> x) - +updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Connection -> Table columnsW columnsR -> Column PGInt4 -> columnsW -> AuditM columnsW +updateDbRow conn table row_id item = do + auditLog $ "Update :" ++ (show item) + _ <- liftIO $ runUpdate conn table (\_ -> item) (matchFunc row_id) + return item + where + matchFunc :: (HasId cmR (Column PGInt4)) => (Column PGInt4 -> cmR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== itId + createRow ::( Show incoming, Show columnsW, @@ -38,13 +46,15 @@ createRow ::( D.Default Constant incoming columnsW, D.Default QueryRunner returned row) => Connection -> Table columnsW returned -> incoming -> AuditM row createRow conn table item = do + auditLog $ "Create : " ++ (show item) currentTime <- liftIO $ fmap pgUTCTime getCurrentTime let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) fmap head $ createDbRows conn table [itemPg] updateRow :: ( - Show haskells, - HasUpdatedat haskells UTCTime + Show columnsW + , Show haskells + , HasUpdatedat haskells UTCTime , D.Default Constant haskells columnsW , D.Default Constant itemId (Column PGInt4) , HasId haskells itemId @@ -53,12 +63,11 @@ updateRow :: ( => Connection -> Table columnsW columnsR -> haskells -> AuditM haskells updateRow conn table item = do auditLog $ "Update : " ++ (show item) - liftIO $ do - currentTime <- getCurrentTime - let itId = item ^. id - let updatedItem = (putUpdatedTimestamp currentTime) item - _ <- runUpdate conn table (\_ -> constant updatedItem) (matchFunc itId) - return updatedItem + let itId = item ^. id + currentTime <- liftIO getCurrentTime + let updatedItem = (putUpdatedTimestamp currentTime) item + updateDbRow conn table (constant itId) (constant updatedItem) + return updatedItem where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp From 4b32bddc01f516798f0a5b95e5de0f59a2bfff14 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 15 Nov 2016 14:48:43 +0000 Subject: [PATCH 32/69] Rename AuditM to AppM --- SpockOpaleye/app/Main.hs | 6 +++--- SpockOpaleye/src/ApiBase.hs | 14 +++++++------- SpockOpaleye/src/DataTypes.hs | 2 +- SpockOpaleye/src/RoleAPi.hs | 4 ++-- SpockOpaleye/src/TenantApi.hs | 12 ++++++------ SpockOpaleye/src/UserApi.hs | 10 +++++----- 6 files changed, 24 insertions(+), 24 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index bda567f..0f738c0 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -32,8 +32,8 @@ main = do DummyAppState runSpock 8080 (spock spockCfg app) -runAuditM :: Connection -> AuditM a -> IO a -runAuditM conn x = do +runAppM :: Connection -> AppM a -> IO a +runAppM conn x = do (item, lg) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) putStrLn lg return item @@ -48,7 +48,7 @@ app = do result <- runQuery (\conn -> validateIncomingTenant conn incomingTenant) case result of Valid -> do - newTenant <- runQuery (\conn -> runAuditM conn $ createTenant conn incomingTenant) + newTenant <- runQuery (\conn -> runAppM conn $ createTenant conn incomingTenant) json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 74689ab..b505929 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -20,16 +20,16 @@ import GHC.Int import Prelude hiding (id) -auditLog :: String -> AuditM () +auditLog :: String -> AppM () auditLog = tell createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) - => Connection -> Table columnsW columnsR -> [columnsW] -> AuditM [haskells] + => Connection -> Table columnsW columnsR -> [columnsW] -> AppM [haskells] createDbRows conn table pgrows = do auditLog $ "Create : " ++ (show pgrows) liftIO $ runInsertManyReturning conn table pgrows (\x -> x) -updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Connection -> Table columnsW columnsR -> Column PGInt4 -> columnsW -> AuditM columnsW +updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Connection -> Table columnsW columnsR -> Column PGInt4 -> columnsW -> AppM columnsW updateDbRow conn table row_id item = do auditLog $ "Update :" ++ (show item) _ <- liftIO $ runUpdate conn table (\_ -> item) (matchFunc row_id) @@ -44,7 +44,7 @@ createRow ::( HasCreatedat columnsW (Maybe (Column PGTimestamptz)), HasUpdatedat columnsW (Column PGTimestamptz), D.Default Constant incoming columnsW, D.Default QueryRunner returned row) - => Connection -> Table columnsW returned -> incoming -> AuditM row + => Connection -> Table columnsW returned -> incoming -> AppM row createRow conn table item = do auditLog $ "Create : " ++ (show item) currentTime <- liftIO $ fmap pgUTCTime getCurrentTime @@ -60,13 +60,13 @@ updateRow :: ( , HasId haskells itemId , HasId columnsR (Column PGInt4) ) - => Connection -> Table columnsW columnsR -> haskells -> AuditM haskells + => Connection -> Table columnsW columnsR -> haskells -> AppM haskells updateRow conn table item = do auditLog $ "Update : " ++ (show item) let itId = item ^. id currentTime <- liftIO getCurrentTime let updatedItem = (putUpdatedTimestamp currentTime) item - updateDbRow conn table (constant itId) (constant updatedItem) + _ <- updateDbRow conn table (constant itId) (constant updatedItem) return updatedItem where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item @@ -79,7 +79,7 @@ removeRow :: ( , D.Default Constant itemId (Column PGInt4) , HasId haskells itemId , HasId columnsR (Column PGInt4) - ) => Connection -> Table columnsW columnsR -> haskells -> AuditM GHC.Int.Int64 + ) => Connection -> Table columnsW columnsR -> haskells -> AppM GHC.Int.Int64 removeRow conn table item = do auditLog $ "Remove : " ++ (show item) liftIO $ do diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index f9e7456..49b40e5 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -18,7 +18,7 @@ import Data.Time (UTCTime) import Database.PostgreSQL.Simple import GHC.Generics -type AuditM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a +type AppM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a data ValidationResult = Valid | Invalid deriving (Eq, Show) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index c3da9af..cf29cb1 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -22,10 +22,10 @@ import ApiBase import Control.Lens import Prelude hiding (id) -createRole :: Connection -> RoleIncoming -> AuditM Role +createRole :: Connection -> RoleIncoming -> AppM Role createRole conn role = createRow conn roleTable role -updateRole :: Connection -> Role -> AuditM Role +updateRole :: Connection -> Role -> AppM Role updateRole conn role = updateRow conn roleTable role removeRole :: Connection -> Role -> IO GHC.Int.Int64 diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index a45b602..8cbfd4d 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -30,24 +30,24 @@ import Prelude hiding (id) import RoleApi import UserApi -createTenant :: Connection -> TenantIncoming -> AuditM Tenant +createTenant :: Connection -> TenantIncoming -> AppM Tenant createTenant conn tenant = do createRow conn tenantTable tenant -activateTenant :: Connection -> Tenant -> AuditM Tenant +activateTenant :: Connection -> Tenant -> AppM Tenant activateTenant conn tenant = setTenantStatus conn tenant TenantStatusActive -deactivateTenant :: Connection -> Tenant -> AuditM Tenant +deactivateTenant :: Connection -> Tenant -> AppM Tenant deactivateTenant conn tenant = setTenantStatus conn tenant TenantStatusInActive -setTenantStatus :: Connection -> Tenant -> TenantStatus -> AuditM Tenant +setTenantStatus :: Connection -> Tenant -> TenantStatus -> AppM Tenant setTenantStatus conn tenant st = updateTenant conn (tenant & status .~ st) -updateTenant :: Connection -> Tenant -> AuditM Tenant +updateTenant :: Connection -> Tenant -> AppM Tenant updateTenant conn tenant = do updateRow conn tenantTable tenant -removeTenant :: Connection -> Tenant -> AuditM GHC.Int.Int64 +removeTenant :: Connection -> Tenant -> AppM GHC.Int.Int64 removeTenant conn tenant = do tenant_deac <- deactivateTenant conn tenant _ <- updateTenant conn (tenant_deac & ownerid .~ Nothing) diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 1621143..3c8b953 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -31,22 +31,22 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -createUser :: Connection -> UserIncoming -> AuditM User +createUser :: Connection -> UserIncoming -> AppM User createUser conn user = do Just hash <- liftIO $ bcryptPassword $ user ^. password let fullUser = user { _userpolyPassword = hash } createRow conn userTable fullUser -updateUser :: Connection -> User -> AuditM User +updateUser :: Connection -> User -> AppM User updateUser conn user = updateRow conn userTable user -activateUser :: Connection -> User -> AuditM User +activateUser :: Connection -> User -> AppM User activateUser conn user = setUserStatus conn user UserStatusActive -deactivateUser :: Connection -> User -> AuditM User +deactivateUser :: Connection -> User -> AppM User deactivateUser conn user = setUserStatus conn user UserStatusInActive -setUserStatus :: Connection -> User -> UserStatus -> AuditM User +setUserStatus :: Connection -> User -> UserStatus -> AppM User setUserStatus conn user newStatus = updateUser conn $ user & status .~ newStatus removeUser :: Connection -> User -> IO GHC.Int.Int64 From ea708d71f691a66b6426d3ded31c2cb1585a2055 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 15 Nov 2016 19:14:19 +0000 Subject: [PATCH 33/69] Added TH functions to create auditable lenses --- SpockOpaleye/SpockOpaleye.cabal | 1 + SpockOpaleye/app/Main.hs | 6 +++ SpockOpaleye/src/DataTypes.hs | 2 + SpockOpaleye/src/TH.hs | 73 +++++++++++++++++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 SpockOpaleye/src/TH.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 9257ccd..a44a025 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -39,6 +39,7 @@ library ,vector ,Spock >=0.11 ,aeson + ,template-haskell default-language: Haskell2010 executable SpockOpaleye-exe diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 0f738c0..8eba9c7 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where @@ -14,6 +15,11 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer import qualified Data.Text as T +import TH +import Data.Time (UTCTime) +import Data.List.NonEmpty + +makeAudtableLenses [t| RolePoly RoleId TenantId T.Text (NonEmpty Permission) UTCTime UTCTime |] data MySession = EmptySession diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 49b40e5..0f41ff1 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -89,6 +89,8 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () +data AuditM a = AuditM { _data:: a, _log:: [String] } deriving (Show) + makeLensesWith abbreviatedFields ''RolePoly makeLensesWith abbreviatedFields ''TenantPoly makeLensesWith abbreviatedFields ''UserPoly diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs new file mode 100644 index 0000000..fd31c22 --- /dev/null +++ b/SpockOpaleye/src/TH.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +import Control.Lens +import Language.Haskell.TH +import Data.Char +import Data.List +import DataTypes + +getTypeSegs :: Type -> [Type] +getTypeSegs a@(ConT n) = [a] +getTypeSegs (AppT a b) = (b : getTypeSegs a) +getTypeSegs r = error $ show r + +typeToName :: Type -> Name +typeToName (ConT n) = n + +makeAudtableLenses :: TypeQ -> Q [Dec] +makeAudtableLenses tq= do + a <- tq + let type_segs = reverse $ getTypeSegs a + let n = typeToName $ head type_segs + field_names <- getRecordFields n + type_params <- getTypeParams n + concat <$> (sequence $ (mkFunc n type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) + where + mkFunc :: Name -> [Name] -> [Type] -> (String, Type) -> Q [Dec] + mkFunc n type_params type_segs (field, typ) = do + let resolved_type = resolve_type typ type_params type_segs + fname <- newName (drop 1 $ (toLower <$> field) ++ "A") + t <- [t|Lens' (AuditM $(tq)) $(return resolved_type)|] + exp <- mkFunc2 field + return [SigD fname t, FunD fname $ [Clause [] (NormalB exp) []] ] + where + resolve_type :: Type -> [Name] -> [Type] -> Type + resolve_type t@(ConT _) _ _ = t + resolve_type (VarT n) tp ts = case (elemIndex n tp) of + Just idx -> (ts !! (idx + 1)) + _ -> error "Unknown type variable" + + +getTypeParams :: Name -> Q [Name] +getTypeParams t_name = do + info <- reify t_name + case info of + TyConI (DataD _ _ params _ [RecC _ t] _) -> return $ toName <$> params + _ -> error $ "Not a record!" ++ (show info) + where + toName (KindedTV n _) = n + +getRecordFields :: Name -> Q [(Name, Type)] +getRecordFields t_name = do + info <- reify t_name + case info of + TyConI (DataD _ _ _ _ [RecC _ t] _) -> return $ ext <$> t + _ -> error $ "Not a record!" ++ (show info) + where + ext (a, _, t) = (a, t) + +mkFunc2 :: String -> Q Exp +mkFunc2 name = do + Just _field_name <- lookupValueName name + fn <- lookupValueName $ "DataTypes." ++ (transformName name) + case fn of + Just field_name -> do + [| lens ($(return $ VarE _field_name)._data) (\r v -> r { + _data = _data r & ($(return $ VarE field_name) .~ v), + _log = ((name ++": " ++ (show $ (_data r ^. $(return $ VarE field_name))) ++ "->" ++ (show v)): (_log r)) + }) |] + _ -> error $ "field accessor not found for " ++ name + where + transformName :: String -> String + transformName name = toLower <$> (dropWhile isLower (drop 1 name)) From 6f80c262eb2077bcc9e1d913a1fd1937528e1a76 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 16 Nov 2016 04:31:50 +0000 Subject: [PATCH 34/69] Generate typeclasses for the auditable wrapper using TH --- SpockOpaleye/app/Main.hs | 27 +++++++++++++++++++++------ SpockOpaleye/src/TH.hs | 34 ++++++++++++++++++++++++++-------- 2 files changed, 47 insertions(+), 14 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 8eba9c7..86bfa2b 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where @@ -14,12 +16,15 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer -import qualified Data.Text as T -import TH -import Data.Time (UTCTime) import Data.List.NonEmpty +import qualified Data.Text as T +import Data.Time +import Prelude hiding (id) +import TH -makeAudtableLenses [t| RolePoly RoleId TenantId T.Text (NonEmpty Permission) UTCTime UTCTime |] +--makeAudtableLenses [t| RolePoly RoleId TenantId T.Text (NonEmpty Permission) UTCTime UTCTime |] +makeAudtableLenses ''Role +makeAudtableLenses ''Tenant data MySession = EmptySession @@ -44,6 +49,16 @@ runAppM conn x = do putStrLn lg return item +getTestTenant :: Tenant +getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + app :: SpockM Connection MySession MyAppState () app = do diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index fd31c22..f20c5b9 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} module TH where import Control.Lens @@ -15,23 +16,40 @@ getTypeSegs r = error $ show r typeToName :: Type -> Name typeToName (ConT n) = n -makeAudtableLenses :: TypeQ -> Q [Dec] +getType :: Name -> TypeQ +getType tn = do + info <- reify tn + case info of + TyConI (TySynD _ _ tpe) -> return tpe + _ -> error "Not a type syn" + +makeAudtableLenses :: Name -> Q [Dec] makeAudtableLenses tq= do - a <- tq + a <- getType tq let type_segs = reverse $ getTypeSegs a let n = typeToName $ head type_segs + let record_name = nameBase n field_names <- getRecordFields n type_params <- getTypeParams n - concat <$> (sequence $ (mkFunc n type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) + concat <$> (sequence $ (mkFunc record_name a type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) where - mkFunc :: Name -> [Name] -> [Type] -> (String, Type) -> Q [Dec] - mkFunc n type_params type_segs (field, typ) = do + mkFunc :: String -> Type -> [Name] -> [Type] -> (String, Type) -> Q [Dec] + mkFunc rec_name t_type type_params type_segs (field, typ) = do let resolved_type = resolve_type typ type_params type_segs - fname <- newName (drop 1 $ (toLower <$> field) ++ "A") - t <- [t|Lens' (AuditM $(tq)) $(return resolved_type)|] + let fname_rt = (drop (1+(length rec_name)) $ (toLower <$> field)) + Just fname_ap <- lookupValueName fname_rt + t <- [t|Lens' (AuditM $(return t_type)) $(return resolved_type)|] exp <- mkFunc2 field - return [SigD fname t, FunD fname $ [Clause [] (NormalB exp) []] ] + do + let tc = "Has" ++ (uc_first fname_rt) + maybe_c <- lookupTypeName tc + case maybe_c of + Just c_name -> do + aud_t <- [t| AuditM $(return t_type) |] + return $ [InstanceD Nothing [] (AppT (AppT (ConT c_name) aud_t) resolved_type) [FunD (fname_ap) $ [Clause [] (NormalB exp) []] ]] + _ -> error $ "Typeclass " ++ tc ++ " not found" where + uc_first (x:xs) = (toUpper x):xs resolve_type :: Type -> [Name] -> [Type] -> Type resolve_type t@(ConT _) _ _ = t resolve_type (VarT n) tp ts = case (elemIndex n tp) of From f940de51602b8a6d5ced87141ab4e651a4f1bf81 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 16 Nov 2016 06:29:37 +0000 Subject: [PATCH 35/69] Clean up warnings and start conversion of audit log to json Value type --- SpockOpaleye/SpockOpaleye.cabal | 1 + SpockOpaleye/app/Main.hs | 2 +- SpockOpaleye/src/ApiBase.hs | 2 -- SpockOpaleye/src/DataTypes.hs | 3 ++- SpockOpaleye/src/TH.hs | 33 +++++++++++++++++++++------------ 5 files changed, 25 insertions(+), 16 deletions(-) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index a44a025..ac7efde 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -56,6 +56,7 @@ executable SpockOpaleye-exe , bcrypt , vector , aeson + , unordered-containers default-language: Haskell2010 test-suite SpockOpaleye-test diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 86bfa2b..a60e83f 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -16,7 +16,6 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer -import Data.List.NonEmpty import qualified Data.Text as T import Data.Time import Prelude hiding (id) @@ -25,6 +24,7 @@ import TH --makeAudtableLenses [t| RolePoly RoleId TenantId T.Text (NonEmpty Permission) UTCTime UTCTime |] makeAudtableLenses ''Role makeAudtableLenses ''Tenant +makeAudtableLenses ''User data MySession = EmptySession diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index b505929..b2e0781 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -71,8 +71,6 @@ updateRow conn table item = do where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp - matchFunc :: (HasId cmR (Column PGInt4), D.Default Constant itemId (Column PGInt4)) => (itemId -> cmR -> Column PGBool) - matchFunc itId item' = (item' ^. id) .== (constant itId) removeRow :: ( Show haskells diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 0f41ff1..8138ddc 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -17,6 +17,7 @@ import Data.Text import Data.Time (UTCTime) import Database.PostgreSQL.Simple import GHC.Generics +import Data.Aeson (Value) type AppM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a @@ -89,7 +90,7 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () -data AuditM a = AuditM { _data:: a, _log:: [String] } deriving (Show) +data AuditM a = AuditM { _data:: a, _log:: Value } deriving (Show) makeLensesWith abbreviatedFields ''RolePoly makeLensesWith abbreviatedFields ''TenantPoly diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index f20c5b9..956fe0b 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -5,16 +5,20 @@ module TH where import Control.Lens import Language.Haskell.TH import Data.Char -import Data.List +import Data.List (elemIndex) import DataTypes +import Data.Vector (fromList) + +import Data.Aeson (Value(..)) getTypeSegs :: Type -> [Type] -getTypeSegs a@(ConT n) = [a] +getTypeSegs a@(ConT _) = [a] getTypeSegs (AppT a b) = (b : getTypeSegs a) getTypeSegs r = error $ show r typeToName :: Type -> Name typeToName (ConT n) = n +typeToName _ = error "Unsupported type constructor" getType :: Name -> TypeQ getType tn = do @@ -38,33 +42,35 @@ makeAudtableLenses tq= do let resolved_type = resolve_type typ type_params type_segs let fname_rt = (drop (1+(length rec_name)) $ (toLower <$> field)) Just fname_ap <- lookupValueName fname_rt - t <- [t|Lens' (AuditM $(return t_type)) $(return resolved_type)|] - exp <- mkFunc2 field + expr <- mkFunc2 field do let tc = "Has" ++ (uc_first fname_rt) maybe_c <- lookupTypeName tc case maybe_c of Just c_name -> do aud_t <- [t| AuditM $(return t_type) |] - return $ [InstanceD Nothing [] (AppT (AppT (ConT c_name) aud_t) resolved_type) [FunD (fname_ap) $ [Clause [] (NormalB exp) []] ]] + return $ [InstanceD Nothing [] (AppT (AppT (ConT c_name) aud_t) resolved_type) [FunD (fname_ap) $ [Clause [] (NormalB expr) []] ]] _ -> error $ "Typeclass " ++ tc ++ " not found" where uc_first (x:xs) = (toUpper x):xs + uc_first [] = [] resolve_type :: Type -> [Name] -> [Type] -> Type resolve_type t@(ConT _) _ _ = t resolve_type (VarT n) tp ts = case (elemIndex n tp) of Just idx -> (ts !! (idx + 1)) _ -> error "Unknown type variable" + resolve_type _ _ _ = error "Should be a type variable or a concrete type" getTypeParams :: Name -> Q [Name] getTypeParams t_name = do info <- reify t_name case info of - TyConI (DataD _ _ params _ [RecC _ t] _) -> return $ toName <$> params + TyConI (DataD _ _ params _ [RecC _ _] _) -> return $ toName <$> params _ -> error $ "Not a record!" ++ (show info) where toName (KindedTV n _) = n + toName _ = error "Unexpected type variable type" getRecordFields :: Name -> Q [(Name, Type)] getRecordFields t_name = do @@ -75,17 +81,20 @@ getRecordFields t_name = do where ext (a, _, t) = (a, t) +make_log :: String -> String -> String -> Value +make_log _ _ _ = Array $ fromList [] + mkFunc2 :: String -> Q Exp -mkFunc2 name = do - Just _field_name <- lookupValueName name - fn <- lookupValueName $ "DataTypes." ++ (transformName name) +mkFunc2 nam = do + Just _field_name <- lookupValueName nam + fn <- lookupValueName $ "DataTypes." ++ (transformName nam) case fn of Just field_name -> do [| lens ($(return $ VarE _field_name)._data) (\r v -> r { _data = _data r & ($(return $ VarE field_name) .~ v), - _log = ((name ++": " ++ (show $ (_data r ^. $(return $ VarE field_name))) ++ "->" ++ (show v)): (_log r)) + _log = make_log nam (show (_data r ^. $(return $ VarE field_name))) (show v) }) |] - _ -> error $ "field accessor not found for " ++ name + _ -> error $ "field accessor not found for " ++ nam where transformName :: String -> String - transformName name = toLower <$> (dropWhile isLower (drop 1 name)) + transformName na = toLower <$> (dropWhile isLower (drop 1 na)) From 18e2dfeb559ffeca14689a83ffa8557013654540 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 16 Nov 2016 17:18:42 +0000 Subject: [PATCH 36/69] Change the audit log to use the json Value object --- SpockOpaleye/app/Main.hs | 1 + SpockOpaleye/src/CryptoDef.hs | 4 ++++ SpockOpaleye/src/JsonInstances.hs | 10 ++++++++++ SpockOpaleye/src/TH.hs | 30 +++++++++++++++++++----------- 4 files changed, 34 insertions(+), 11 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index a60e83f..e40db1b 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -5,6 +5,7 @@ module Main where +import Data.Aeson (ToJSON (..), Value (..)) import Database.PostgreSQL.Simple import DataTypes import JsonInstances () diff --git a/SpockOpaleye/src/CryptoDef.hs b/SpockOpaleye/src/CryptoDef.hs index 1464138..2f12c58 100644 --- a/SpockOpaleye/src/CryptoDef.hs +++ b/SpockOpaleye/src/CryptoDef.hs @@ -14,6 +14,7 @@ import Data.Text import Data.Text.Encoding import Database.PostgreSQL.Simple.FromField import Opaleye +import Data.Aeson (ToJSON(..), Value(..)) newtype BcryptPassword = BcryptPassword ByteString @@ -38,3 +39,6 @@ instance FromField BcryptPassword where instance QueryRunnerColumnDefault PGBytea BcryptPassword where queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance ToJSON BcryptPassword where + toJSON x = String "" diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index af86a8d..8504fb1 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -9,6 +9,7 @@ import Data.Aeson.Types import Data.Char import Data.Text import DataTypes +import CryptoDef instance FromJSON UserId where parseJSON j@(Number _) = UserId <$> (parseJSON j) @@ -61,3 +62,12 @@ instance ToJSON UserId where instance ToJSON TenantId where toJSON = genericToJSON defaultOptions toEncoding = genericToEncoding defaultOptions + +instance ToJSON UserStatus where + toJSON x = String $ Data.Text.pack $ show x + +instance ToJSON RoleId where + toJSON (RoleId x) = toJSON x + +instance ToJSON Permission where + toJSON x = toJSON $ show x diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 956fe0b..10befe2 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module TH where @@ -8,8 +9,10 @@ import Data.Char import Data.List (elemIndex) import DataTypes import Data.Vector (fromList) +import qualified Data.HashMap.Strict as HM +import Data.Text (pack) -import Data.Aeson (Value(..)) +import Data.Aeson (Value(..), ToJSON(..)) getTypeSegs :: Type -> [Type] getTypeSegs a@(ConT _) = [a] @@ -35,14 +38,14 @@ makeAudtableLenses tq= do let record_name = nameBase n field_names <- getRecordFields n type_params <- getTypeParams n - concat <$> (sequence $ (mkFunc record_name a type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) + concat <$> (sequence $ (mkInstanceDef record_name a type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) where - mkFunc :: String -> Type -> [Name] -> [Type] -> (String, Type) -> Q [Dec] - mkFunc rec_name t_type type_params type_segs (field, typ) = do + mkInstanceDef :: String -> Type -> [Name] -> [Type] -> (String, Type) -> Q [Dec] + mkInstanceDef rec_name t_type type_params type_segs (field, typ) = do let resolved_type = resolve_type typ type_params type_segs let fname_rt = (drop (1+(length rec_name)) $ (toLower <$> field)) Just fname_ap <- lookupValueName fname_rt - expr <- mkFunc2 field + expr <- mkInstanceFunction field do let tc = "Has" ++ (uc_first fname_rt) maybe_c <- lookupTypeName tc @@ -61,7 +64,6 @@ makeAudtableLenses tq= do _ -> error "Unknown type variable" resolve_type _ _ _ = error "Should be a type variable or a concrete type" - getTypeParams :: Name -> Q [Name] getTypeParams t_name = do info <- reify t_name @@ -81,18 +83,24 @@ getRecordFields t_name = do where ext (a, _, t) = (a, t) -make_log :: String -> String -> String -> Value -make_log _ _ _ = Array $ fromList [] +makeLog :: (ToJSON a) => Value -> String -> a -> a -> Value +makeLog current_log field_name old new = case current_log of + Object v -> Object $ HM.insert field_name_txt (getLog old new) v + where + field_name_txt = pack field_name + getLog :: (ToJSON v) => v -> v -> Value + getLog old new = Object $ HM.insert "old" (toJSON old) $ HM.insert "new" (toJSON new) $ HM.empty -mkFunc2 :: String -> Q Exp -mkFunc2 nam = do +mkInstanceFunction :: String -> Q Exp +mkInstanceFunction nam = do Just _field_name <- lookupValueName nam + -- TODO remove dependency on "DataTypes" module name or don't hard code it in. fn <- lookupValueName $ "DataTypes." ++ (transformName nam) case fn of Just field_name -> do [| lens ($(return $ VarE _field_name)._data) (\r v -> r { _data = _data r & ($(return $ VarE field_name) .~ v), - _log = make_log nam (show (_data r ^. $(return $ VarE field_name))) (show v) + _log = makeLog (_log r) nam (_data r ^. $(return $ VarE field_name)) v }) |] _ -> error $ "field accessor not found for " ++ nam where From c6f7d141ffcc97d0e0f6a1f65ca634170c20727c Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 16 Nov 2016 17:39:16 +0000 Subject: [PATCH 37/69] Added type syns for AuditM wrapper --- SpockOpaleye/src/ApiBase.hs | 2 +- SpockOpaleye/src/DataTypes.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index b2e0781..e1f471b 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -49,7 +49,7 @@ createRow conn table item = do auditLog $ "Create : " ++ (show item) currentTime <- liftIO $ fmap pgUTCTime getCurrentTime let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) - fmap head $ createDbRows conn table [itemPg] + fmap (head) $ createDbRows conn table [itemPg] updateRow :: ( Show columnsW diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 8138ddc..536637d 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -17,7 +17,8 @@ import Data.Text import Data.Time (UTCTime) import Database.PostgreSQL.Simple import GHC.Generics -import Data.Aeson (Value) +import Data.Aeson (Value(..)) +import qualified Data.HashMap.Strict as HM type AppM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a @@ -92,6 +93,13 @@ type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () data AuditM a = AuditM { _data:: a, _log:: Value } deriving (Show) +auditM :: a -> AuditM a +auditM a = AuditM {_data = a, _log = Object HM.empty} + +type TenantA = AuditM Tenant +type RoleA = AuditM Role +type UserA = AuditM User + makeLensesWith abbreviatedFields ''RolePoly makeLensesWith abbreviatedFields ''TenantPoly makeLensesWith abbreviatedFields ''UserPoly From 03a33ccf0000f39b827ace79f61e7e7b128f2381 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 17 Nov 2016 06:08:09 +0000 Subject: [PATCH 38/69] Convert all the api function to run in AppM --- SpockOpaleye/app/Main.hs | 9 +++-- SpockOpaleye/src/ApiBase.hs | 40 ++++++++++++++------- SpockOpaleye/src/DataTypes.hs | 10 ++++-- SpockOpaleye/src/JsonInstances.hs | 1 - SpockOpaleye/src/RoleAPi.hs | 23 ++++++------ SpockOpaleye/src/TH.hs | 4 +-- SpockOpaleye/src/TenantApi.hs | 60 +++++++++++++++---------------- SpockOpaleye/src/UserApi.hs | 54 +++++++++++++--------------- SpockOpaleye/src/Validations.hs | 9 +++-- 9 files changed, 110 insertions(+), 100 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index e40db1b..6e69cc7 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -5,7 +5,6 @@ module Main where -import Data.Aeson (ToJSON (..), Value (..)) import Database.PostgreSQL.Simple import DataTypes import JsonInstances () @@ -44,8 +43,8 @@ main = do DummyAppState runSpock 8080 (spock spockCfg app) -runAppM :: Connection -> AppM a -> IO a -runAppM conn x = do +runAppM :: AppM a -> Connection -> IO a +runAppM x conn = do (item, lg) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) putStrLn lg return item @@ -67,10 +66,10 @@ app = do do maybeTenantIncoming <- jsonBody case maybeTenantIncoming of Just incomingTenant -> do - result <- runQuery (\conn -> validateIncomingTenant conn incomingTenant) + result <- runQuery $ runAppM $ validateIncomingTenant incomingTenant case result of Valid -> do - newTenant <- runQuery (\conn -> runAppM conn $ createTenant conn incomingTenant) + newTenant <- runQuery $ runAppM $ createTenant incomingTenant json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index e1f471b..7e150e9 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -13,7 +13,6 @@ import Control.Monad.Reader import Control.Monad.Writer import qualified Data.Profunctor.Product.Default as D import Data.Time (UTCTime, getCurrentTime) -import Database.PostgreSQL.Simple import DataTypes import Opaleye import GHC.Int @@ -23,15 +22,22 @@ import Prelude hiding (id) auditLog :: String -> AppM () auditLog = tell +removeRawDbRows :: Table columnsW columnsR -> (columnsR -> Column PGBool) -> AppM GHC.Int.Int64 +removeRawDbRows table matchFunc = do + conn <- getConnection + liftIO $ runDelete conn table matchFunc + createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) - => Connection -> Table columnsW columnsR -> [columnsW] -> AppM [haskells] -createDbRows conn table pgrows = do + => Table columnsW columnsR -> [columnsW] -> AppM [haskells] +createDbRows table pgrows = do auditLog $ "Create : " ++ (show pgrows) + conn <- getConnection liftIO $ runInsertManyReturning conn table pgrows (\x -> x) -updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Connection -> Table columnsW columnsR -> Column PGInt4 -> columnsW -> AppM columnsW -updateDbRow conn table row_id item = do +updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Table columnsW columnsR -> Column PGInt4 -> columnsW -> AppM columnsW +updateDbRow table row_id item = do auditLog $ "Update :" ++ (show item) + conn <- getConnection _ <- liftIO $ runUpdate conn table (\_ -> item) (matchFunc row_id) return item where @@ -44,12 +50,12 @@ createRow ::( HasCreatedat columnsW (Maybe (Column PGTimestamptz)), HasUpdatedat columnsW (Column PGTimestamptz), D.Default Constant incoming columnsW, D.Default QueryRunner returned row) - => Connection -> Table columnsW returned -> incoming -> AppM row -createRow conn table item = do + => Table columnsW returned -> incoming -> AppM row +createRow table item = do auditLog $ "Create : " ++ (show item) currentTime <- liftIO $ fmap pgUTCTime getCurrentTime let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) - fmap (head) $ createDbRows conn table [itemPg] + fmap (head) $ createDbRows table [itemPg] updateRow :: ( Show columnsW @@ -60,13 +66,13 @@ updateRow :: ( , HasId haskells itemId , HasId columnsR (Column PGInt4) ) - => Connection -> Table columnsW columnsR -> haskells -> AppM haskells -updateRow conn table item = do + => Table columnsW columnsR -> haskells -> AppM haskells +updateRow table item = do auditLog $ "Update : " ++ (show item) let itId = item ^. id currentTime <- liftIO getCurrentTime let updatedItem = (putUpdatedTimestamp currentTime) item - _ <- updateDbRow conn table (constant itId) (constant updatedItem) + _ <- updateDbRow table (constant itId) (constant updatedItem) return updatedItem where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item @@ -77,9 +83,10 @@ removeRow :: ( , D.Default Constant itemId (Column PGInt4) , HasId haskells itemId , HasId columnsR (Column PGInt4) - ) => Connection -> Table columnsW columnsR -> haskells -> AppM GHC.Int.Int64 -removeRow conn table item = do + ) => Table columnsW columnsR -> haskells -> AppM GHC.Int.Int64 +removeRow table item = do auditLog $ "Remove : " ++ (show item) + conn <- getConnection liftIO $ do runDelete conn table $ matchFunc $ item ^. id where @@ -88,3 +95,10 @@ removeRow conn table item = do D.Default Constant itemId (Column PGInt4) ) => (itemId -> columnsR -> Column PGBool) matchFunc itId item' = (item' ^. id) .== (constant itId) + +readRow :: (D.Default QueryRunner columnsR haskells) => + Opaleye.Query columnsR -> AppM [haskells] +readRow query' = do + conn <- getConnection + liftIO $ runQuery conn query' + diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 536637d..cfff345 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -9,8 +9,9 @@ module DataTypes where import Control.Lens -import Control.Monad.Reader -import Control.Monad.Writer +import qualified Control.Monad.Reader as R +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer import CryptoDef import Data.List.NonEmpty import Data.Text @@ -22,6 +23,11 @@ import qualified Data.HashMap.Strict as HM type AppM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a +getConnection :: AppM Connection +getConnection = do + (conn, _, _) <- R.ask + return conn + data ValidationResult = Valid | Invalid deriving (Eq, Show) diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 8504fb1..b657c15 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -9,7 +9,6 @@ import Data.Aeson.Types import Data.Char import Data.Text import DataTypes -import CryptoDef instance FromJSON UserId where parseJSON j@(Number _) = UserId <$> (parseJSON j) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index cf29cb1..11d78c5 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -12,7 +12,6 @@ module RoleApi ) where import Control.Arrow -import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int import Opaleye @@ -22,23 +21,23 @@ import ApiBase import Control.Lens import Prelude hiding (id) -createRole :: Connection -> RoleIncoming -> AppM Role -createRole conn role = createRow conn roleTable role +createRole :: RoleIncoming -> AppM Role +createRole role = createRow roleTable role -updateRole :: Connection -> Role -> AppM Role -updateRole conn role = updateRow conn roleTable role +updateRole :: Role -> AppM Role +updateRole role = updateRow roleTable role -removeRole :: Connection -> Role -> IO GHC.Int.Int64 -removeRole conn role = do - _ <- runDelete conn userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) - runDelete conn roleTable matchFunc +removeRole :: Role -> AppM GHC.Int.Int64 +removeRole role = do + _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) + removeRawDbRows roleTable matchFunc where tId = role ^. id matchFunc role' = (role' ^. id).== constant tId -readRolesForTenant :: Connection -> TenantId -> IO [Role] -readRolesForTenant conn tId = do - runQuery conn $ roleQueryForTenant tId +readRolesForTenant :: TenantId -> AppM [Role] +readRolesForTenant tId = do + readRow $ roleQueryForTenant tId roleQuery :: Query RoleTableR roleQuery = queryTable roleTable diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 10befe2..62af8f5 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -8,7 +8,6 @@ import Language.Haskell.TH import Data.Char import Data.List (elemIndex) import DataTypes -import Data.Vector (fromList) import qualified Data.HashMap.Strict as HM import Data.Text (pack) @@ -86,10 +85,11 @@ getRecordFields t_name = do makeLog :: (ToJSON a) => Value -> String -> a -> a -> Value makeLog current_log field_name old new = case current_log of Object v -> Object $ HM.insert field_name_txt (getLog old new) v + _ -> error "Unexpected value in the log field" where field_name_txt = pack field_name getLog :: (ToJSON v) => v -> v -> Value - getLog old new = Object $ HM.insert "old" (toJSON old) $ HM.insert "new" (toJSON new) $ HM.empty + getLog old' new' = Object $ HM.insert "old" (toJSON old') $ HM.insert "new" (toJSON new') $ HM.empty mkInstanceFunction :: String -> Q Exp mkInstanceFunction nam = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 8cbfd4d..e3d436b 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -21,7 +21,6 @@ import Control.Lens import Control.Monad.Reader import Data.Maybe import Data.Text -import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int import Opaleye @@ -30,48 +29,47 @@ import Prelude hiding (id) import RoleApi import UserApi -createTenant :: Connection -> TenantIncoming -> AppM Tenant -createTenant conn tenant = do - createRow conn tenantTable tenant +createTenant :: TenantIncoming -> AppM Tenant +createTenant tenant = do + createRow tenantTable tenant -activateTenant :: Connection -> Tenant -> AppM Tenant -activateTenant conn tenant = setTenantStatus conn tenant TenantStatusActive +activateTenant :: Tenant -> AppM Tenant +activateTenant tenant = setTenantStatus tenant TenantStatusActive -deactivateTenant :: Connection -> Tenant -> AppM Tenant -deactivateTenant conn tenant = setTenantStatus conn tenant TenantStatusInActive +deactivateTenant :: Tenant -> AppM Tenant +deactivateTenant tenant = setTenantStatus tenant TenantStatusInActive -setTenantStatus :: Connection -> Tenant -> TenantStatus -> AppM Tenant -setTenantStatus conn tenant st = updateTenant conn (tenant & status .~ st) +setTenantStatus :: Tenant -> TenantStatus -> AppM Tenant +setTenantStatus tenant st = updateTenant (tenant & status .~ st) -updateTenant :: Connection -> Tenant -> AppM Tenant -updateTenant conn tenant = do - updateRow conn tenantTable tenant +updateTenant :: Tenant -> AppM Tenant +updateTenant tenant = do + updateRow tenantTable tenant -removeTenant :: Connection -> Tenant -> AppM GHC.Int.Int64 -removeTenant conn tenant = do - tenant_deac <- deactivateTenant conn tenant - _ <- updateTenant conn (tenant_deac & ownerid .~ Nothing) - liftIO $ do - usersForTenant <- readUsersForTenant conn tid - rolesForTenant <- readRolesForTenant conn tid - mapM_ (removeRole conn) rolesForTenant - mapM_ (removeUser conn) usersForTenant - runDelete conn tenantTable matchFunc +removeTenant :: Tenant -> AppM GHC.Int.Int64 +removeTenant tenant = do + tenant_deac <- deactivateTenant tenant + _ <- updateTenant (tenant_deac & ownerid .~ Nothing) + usersForTenant <- readUsersForTenant tid + rolesForTenant <- readRolesForTenant tid + mapM_ removeRole rolesForTenant + mapM_ removeUser usersForTenant + removeRawDbRows tenantTable matchFunc where tid = tenant ^. id matchFunc :: TenantTableR -> Column PGBool matchFunc tenant' = (tenant' ^. id) .== (constant tid) -readTenants :: Connection -> IO [Tenant] -readTenants conn = runQuery conn tenantQuery +readTenants :: AppM [Tenant] +readTenants = readRow tenantQuery -readTenantById :: Connection -> TenantId -> IO (Maybe Tenant) -readTenantById conn tenantId = do - listToMaybe <$> (runQuery conn $ (tenantQueryById tenantId)) +readTenantById :: TenantId -> AppM (Maybe Tenant) +readTenantById tenantId = do + listToMaybe <$> (readRow (tenantQueryById tenantId)) -readTenantByBackofficedomain :: Connection -> Text -> IO (Maybe Tenant) -readTenantByBackofficedomain conn domain = do - listToMaybe <$> (runQuery conn $ (tenantQueryByBackoffocedomain domain)) +readTenantByBackofficedomain :: Text -> AppM (Maybe Tenant) +readTenantByBackofficedomain domain = do + listToMaybe <$> (readRow (tenantQueryByBackoffocedomain domain)) tenantQuery :: Opaleye.Query TenantTableR tenantQuery = queryTable tenantTable diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 3c8b953..65a2a14 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -22,7 +22,6 @@ import Control.Arrow import Control.Lens import Control.Monad.IO.Class import Data.Maybe -import Database.PostgreSQL.Simple (Connection) import DataTypes import GHC.Int import Opaleye @@ -31,46 +30,43 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -createUser :: Connection -> UserIncoming -> AppM User -createUser conn user = do +createUser :: UserIncoming -> AppM User +createUser user = do Just hash <- liftIO $ bcryptPassword $ user ^. password let fullUser = user { _userpolyPassword = hash } - createRow conn userTable fullUser + createRow userTable fullUser -updateUser :: Connection -> User -> AppM User -updateUser conn user = updateRow conn userTable user +updateUser :: User -> AppM User +updateUser user = updateRow userTable user -activateUser :: Connection -> User -> AppM User -activateUser conn user = setUserStatus conn user UserStatusActive +activateUser :: User -> AppM User +activateUser user = setUserStatus user UserStatusActive -deactivateUser :: Connection -> User -> AppM User -deactivateUser conn user = setUserStatus conn user UserStatusInActive +deactivateUser :: User -> AppM User +deactivateUser user = setUserStatus user UserStatusInActive -setUserStatus :: Connection -> User -> UserStatus -> AppM User -setUserStatus conn user newStatus = updateUser conn $ user & status .~ newStatus +setUserStatus :: User -> UserStatus -> AppM User +setUserStatus user newStatus = updateUser $ user & status .~ newStatus -removeUser :: Connection -> User -> IO GHC.Int.Int64 -removeUser conn rUser = - runDelete conn userTable matchFunction - where - matchFunction user = (user ^. id).== constant (rUser ^. id) +removeUser :: User -> AppM GHC.Int.Int64 +removeUser rUser = removeRow userTable rUser -readUsers :: Connection -> IO [User] -readUsers conn = runQuery conn userQuery +readUsers :: AppM [User] +readUsers = readRow userQuery -readUsersForTenant :: Connection -> TenantId -> IO [User] -readUsersForTenant conn tenantId = runQuery conn $ userQueryByTenantid tenantId +readUsersForTenant :: TenantId -> AppM [User] +readUsersForTenant tenantId = readRow $ userQueryByTenantid tenantId -readUserById :: Connection -> UserId -> IO (Maybe User) -readUserById conn id' = do - listToMaybe <$> (runQuery conn $ userQueryById id') +readUserById :: UserId -> AppM (Maybe User) +readUserById id' = do + listToMaybe <$> (readRow $ userQueryById id') -addRoleToUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -addRoleToUser conn userId roleId = - runInsertMany conn userRolePivotTable (return (constant userId, constant roleId)) +addRoleToUser :: UserId -> RoleId -> AppM [(UserId, RoleId)] +addRoleToUser userId roleId = + createDbRows userRolePivotTable [(constant (userId, roleId))] -removeRoleFromUser :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -removeRoleFromUser conn tUserId tRoleId = runDelete conn userRolePivotTable +removeRoleFromUser :: UserId -> RoleId -> AppM GHC.Int.Int64 +removeRoleFromUser tUserId tRoleId = removeRawDbRows userRolePivotTable (\(userId, roleId) -> (userId .== constant tUserId) .&& (roleId .== constant tRoleId)) userQuery :: Query UserTableR diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 642e713..12d2fee 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -11,12 +11,11 @@ module Validations where import Control.Lens import Data.Maybe import qualified Data.Text as T -import Database.PostgreSQL.Simple import DataTypes import TenantApi -validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult -validateIncomingTenant conn tenant = do +validateIncomingTenant :: TenantIncoming -> AppM ValidationResult +validateIncomingTenant tenant = do unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain) return $ if and [unique_bod, validate_name, validate_contact] @@ -25,5 +24,5 @@ validateIncomingTenant conn tenant = do 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 <$> readTenantByBackofficedomain conn domain + check_for_unique_bo_domain :: T.Text -> AppM Bool + check_for_unique_bo_domain domain = isNothing <$> readTenantByBackofficedomain domain From 7b4ba298502298ecbf761c4e53d3f151515ef511 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 17 Nov 2016 10:02:22 +0000 Subject: [PATCH 39/69] Use Auditable models in api functions --- SpockOpaleye/app/Main.hs | 7 ------- SpockOpaleye/src/ApiBase.hs | 27 ++++++++++++++++++++++++++- SpockOpaleye/src/CryptoDef.hs | 2 +- SpockOpaleye/src/DataTypes.hs | 15 +++++++++------ SpockOpaleye/src/JsonInstances.hs | 6 ++++++ SpockOpaleye/src/RoleAPi.hs | 12 ++++++------ SpockOpaleye/src/TH.hs | 2 +- SpockOpaleye/src/TenantApi.hs | 28 ++++++++++++++-------------- SpockOpaleye/src/UserApi.hs | 30 +++++++++++++++--------------- 9 files changed, 78 insertions(+), 51 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 6e69cc7..32d3538 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TemplateHaskell #-} module Main where - import Database.PostgreSQL.Simple import DataTypes import JsonInstances () @@ -19,12 +18,6 @@ import Control.Monad.Writer import qualified Data.Text as T import Data.Time import Prelude hiding (id) -import TH - ---makeAudtableLenses [t| RolePoly RoleId TenantId T.Text (NonEmpty Permission) UTCTime UTCTime |] -makeAudtableLenses ''Role -makeAudtableLenses ''Tenant -makeAudtableLenses ''User data MySession = EmptySession diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 7e150e9..39980b9 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -17,7 +17,12 @@ import DataTypes import Opaleye import GHC.Int import Prelude hiding (id) +import TH +import JsonInstances () +makeAudtableLenses ''Role +makeAudtableLenses ''Tenant +makeAudtableLenses ''User auditLog :: String -> AppM () auditLog = tell @@ -78,6 +83,27 @@ updateRow table item = do putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp +updateAuditableRow :: ( + Show columnsW + , HasUpdatedat (Auditable haskells) UTCTime + , D.Default Constant haskells columnsW + , D.Default Constant itemId (Column PGInt4) + , HasId (Auditable haskells) itemId + , HasId columnsR (Column PGInt4) + ) + => Table columnsW columnsR -> Auditable haskells -> AppM (Auditable haskells) +updateAuditableRow table audti = do + --auditLog $ "Update : " ++ (show item) + let itId = audti ^. id + currentTime <- liftIO getCurrentTime + let updatedItem = (putUpdatedTimestamp currentTime) audti + let Auditable { _data = item, _log = _} = updatedItem + _ <- updateDbRow table (constant itId) (constant item) + return audti + where + putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item + putUpdatedTimestamp timestamp = updatedat .~ timestamp + removeRow :: ( Show haskells , D.Default Constant itemId (Column PGInt4) @@ -101,4 +127,3 @@ readRow :: (D.Default QueryRunner columnsR haskells) => readRow query' = do conn <- getConnection liftIO $ runQuery conn query' - diff --git a/SpockOpaleye/src/CryptoDef.hs b/SpockOpaleye/src/CryptoDef.hs index 2f12c58..15b783b 100644 --- a/SpockOpaleye/src/CryptoDef.hs +++ b/SpockOpaleye/src/CryptoDef.hs @@ -41,4 +41,4 @@ instance QueryRunnerColumnDefault PGBytea BcryptPassword where queryRunnerColumnDefault = fieldQueryRunnerColumn instance ToJSON BcryptPassword where - toJSON x = String "" + toJSON _ = String "" diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index cfff345..6985d82 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -97,14 +97,17 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () -data AuditM a = AuditM { _data:: a, _log:: Value } deriving (Show) +data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) -auditM :: a -> AuditM a -auditM a = AuditM {_data = a, _log = Object HM.empty} +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} -type TenantA = AuditM Tenant -type RoleA = AuditM Role -type UserA = AuditM User +type TenantA = Auditable Tenant +type RoleA = Auditable Role +type UserA = Auditable User + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a makeLensesWith abbreviatedFields ''RolePoly makeLensesWith abbreviatedFields ''TenantPoly diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index b657c15..1e808ae 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -10,6 +10,9 @@ import Data.Char import Data.Text import DataTypes +instance (FromJSON a) => FromJSON (Auditable a) where + parseJSON j = auditable <$> (parseJSON j) + instance FromJSON UserId where parseJSON j@(Number _) = UserId <$> (parseJSON j) parseJSON invalid = typeMismatch "UserId" invalid @@ -70,3 +73,6 @@ instance ToJSON RoleId where instance ToJSON Permission where toJSON x = toJSON $ show x + +instance (ToJSON a) => ToJSON (Auditable a) where + toJSON Auditable {_data = x} = toJSON x diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 11d78c5..a2b2826 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -21,23 +21,23 @@ import ApiBase import Control.Lens import Prelude hiding (id) -createRole :: RoleIncoming -> AppM Role -createRole role = createRow roleTable role +createRole :: RoleIncoming -> AppM (Auditable Role) +createRole role = auditable <$> createRow roleTable role updateRole :: Role -> AppM Role updateRole role = updateRow roleTable role -removeRole :: Role -> AppM GHC.Int.Int64 -removeRole role = do +removeRole :: Auditable Role -> AppM GHC.Int.Int64 +removeRole Auditable {_data = role} = do _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) removeRawDbRows roleTable matchFunc where tId = role ^. id matchFunc role' = (role' ^. id).== constant tId -readRolesForTenant :: TenantId -> AppM [Role] +readRolesForTenant :: TenantId -> AppM [Auditable Role] readRolesForTenant tId = do - readRow $ roleQueryForTenant tId + wrapAuditable $ readRow $ roleQueryForTenant tId roleQuery :: Query RoleTableR roleQuery = queryTable roleTable diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 62af8f5..9902177 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -50,7 +50,7 @@ makeAudtableLenses tq= do maybe_c <- lookupTypeName tc case maybe_c of Just c_name -> do - aud_t <- [t| AuditM $(return t_type) |] + aud_t <- [t| Auditable $(return t_type) |] return $ [InstanceD Nothing [] (AppT (AppT (ConT c_name) aud_t) resolved_type) [FunD (fname_ap) $ [Clause [] (NormalB expr) []] ]] _ -> error $ "Typeclass " ++ tc ++ " not found" where diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index e3d436b..ef1a86e 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -29,24 +29,24 @@ import Prelude hiding (id) import RoleApi import UserApi -createTenant :: TenantIncoming -> AppM Tenant +createTenant :: TenantIncoming -> AppM (Auditable Tenant) createTenant tenant = do - createRow tenantTable tenant + auditable <$> createRow tenantTable tenant -activateTenant :: Tenant -> AppM Tenant +activateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) activateTenant tenant = setTenantStatus tenant TenantStatusActive -deactivateTenant :: Tenant -> AppM Tenant +deactivateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) deactivateTenant tenant = setTenantStatus tenant TenantStatusInActive -setTenantStatus :: Tenant -> TenantStatus -> AppM Tenant +setTenantStatus :: (Auditable Tenant) -> TenantStatus -> AppM (Auditable Tenant) setTenantStatus tenant st = updateTenant (tenant & status .~ st) -updateTenant :: Tenant -> AppM Tenant +updateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) updateTenant tenant = do - updateRow tenantTable tenant + updateAuditableRow tenantTable tenant -removeTenant :: Tenant -> AppM GHC.Int.Int64 +removeTenant :: Auditable Tenant -> AppM GHC.Int.Int64 removeTenant tenant = do tenant_deac <- deactivateTenant tenant _ <- updateTenant (tenant_deac & ownerid .~ Nothing) @@ -60,16 +60,16 @@ removeTenant tenant = do matchFunc :: TenantTableR -> Column PGBool matchFunc tenant' = (tenant' ^. id) .== (constant tid) -readTenants :: AppM [Tenant] -readTenants = readRow tenantQuery +readTenants :: AppM [Auditable Tenant] +readTenants = wrapAuditable $ readRow tenantQuery -readTenantById :: TenantId -> AppM (Maybe Tenant) +readTenantById :: TenantId -> AppM (Maybe (Auditable Tenant)) readTenantById tenantId = do - listToMaybe <$> (readRow (tenantQueryById tenantId)) + wrapAuditable $ listToMaybe <$> (readRow (tenantQueryById tenantId)) -readTenantByBackofficedomain :: Text -> AppM (Maybe Tenant) +readTenantByBackofficedomain :: Text -> AppM (Maybe (Auditable Tenant)) readTenantByBackofficedomain domain = do - listToMaybe <$> (readRow (tenantQueryByBackoffocedomain domain)) + wrapAuditable $ listToMaybe <$> (readRow (tenantQueryByBackoffocedomain domain)) tenantQuery :: Opaleye.Query TenantTableR tenantQuery = queryTable tenantTable diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 65a2a14..6d7b816 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -30,36 +30,36 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -createUser :: UserIncoming -> AppM User +createUser :: UserIncoming -> AppM (Auditable User) createUser user = do Just hash <- liftIO $ bcryptPassword $ user ^. password let fullUser = user { _userpolyPassword = hash } - createRow userTable fullUser + auditable <$> (createRow userTable fullUser) -updateUser :: User -> AppM User -updateUser user = updateRow userTable user +updateUser :: Auditable User -> AppM (Auditable User) +updateUser user = updateAuditableRow userTable user -activateUser :: User -> AppM User +activateUser :: Auditable User -> AppM (Auditable User) activateUser user = setUserStatus user UserStatusActive -deactivateUser :: User -> AppM User +deactivateUser :: Auditable User -> AppM (Auditable User) deactivateUser user = setUserStatus user UserStatusInActive -setUserStatus :: User -> UserStatus -> AppM User +setUserStatus :: Auditable User -> UserStatus -> AppM (Auditable User) setUserStatus user newStatus = updateUser $ user & status .~ newStatus -removeUser :: User -> AppM GHC.Int.Int64 -removeUser rUser = removeRow userTable rUser +removeUser :: Auditable User -> AppM GHC.Int.Int64 +removeUser Auditable { _data = rUser} = removeRow userTable rUser -readUsers :: AppM [User] -readUsers = readRow userQuery +readUsers :: AppM [Auditable User] +readUsers = wrapAuditable $ readRow userQuery -readUsersForTenant :: TenantId -> AppM [User] -readUsersForTenant tenantId = readRow $ userQueryByTenantid tenantId +readUsersForTenant :: TenantId -> AppM [Auditable User] +readUsersForTenant tenantId = wrapAuditable $ readRow $ userQueryByTenantid tenantId -readUserById :: UserId -> AppM (Maybe User) +readUserById :: UserId -> AppM (Maybe (Auditable User)) readUserById id' = do - listToMaybe <$> (readRow $ userQueryById id') + wrapAuditable $ listToMaybe <$> (readRow $ userQueryById id') addRoleToUser :: UserId -> RoleId -> AppM [(UserId, RoleId)] addRoleToUser userId roleId = From 6ebf760287d450f8925b9284c4c7e252924a7ade Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 17 Nov 2016 11:48:42 +0000 Subject: [PATCH 40/69] Insert log to db on update calls --- SpockOpaleye/src/ApiBase.hs | 30 +++++++++++++++++++++++++++++- SpockOpaleye/src/DataTypes.hs | 12 +++++++++++- SpockOpaleye/src/OpaleyeDef.hs | 32 ++++++++++++++++++++++++++++++++ 3 files changed, 72 insertions(+), 2 deletions(-) diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 39980b9..ec91607 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -15,9 +15,12 @@ import qualified Data.Profunctor.Product.Default as D import Data.Time (UTCTime, getCurrentTime) import DataTypes import Opaleye +import OpaleyeDef +import qualified Data.Text as T import GHC.Int import Prelude hiding (id) import TH +import Data.Aeson (Value(..)) import JsonInstances () makeAudtableLenses ''Role @@ -97,13 +100,38 @@ updateAuditableRow table audti = do let itId = audti ^. id currentTime <- liftIO getCurrentTime let updatedItem = (putUpdatedTimestamp currentTime) audti - let Auditable { _data = item, _log = _} = updatedItem + let Auditable { _data = item, _log = _log} = updatedItem _ <- updateDbRow table (constant itId) (constant item) + insertIntoLog table itId "" _log return audti where putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item putUpdatedTimestamp timestamp = updatedat .~ timestamp +insertIntoLog :: ( + D.Default Constant item_id (Column PGInt4) + ) => Table a b -> item_id -> T.Text -> Value -> AppM () +insertIntoLog table auditable_id summary changes = do + case table of + Table table_name _ -> do + Just tenant <- getCurrentTenant + Just user <- getCurrentUser + conn <- getConnection + let tenant_id = tenant ^. id + let user_id = user ^. id + _ <- liftIO $ runInsertMany conn auditTable [( + (), + constant tenant_id, + Just $ constant user_id, + Just $ pgBool False, + constant auditable_id, + pgStrictText $ T.pack table_name, + pgStrictText $ summary, + constant changes, + Nothing)] + return () + _ -> error "Unsupported Table constructor" + removeRow :: ( Show haskells , D.Default Constant itemId (Column PGInt4) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 6985d82..5234f00 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -21,13 +21,23 @@ import GHC.Generics import Data.Aeson (Value(..)) import qualified Data.HashMap.Strict as HM -type AppM a = WriterT String (ReaderT (Connection, Maybe Tenant, Maybe User) IO) a +type AppM a = WriterT String (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) IO) a getConnection :: AppM Connection getConnection = do (conn, _, _) <- R.ask return conn +getCurrentTenant :: AppM (Maybe (Auditable Tenant)) +getCurrentTenant = do + (_, tenant, _) <- R.ask + return tenant + +getCurrentUser :: AppM (Maybe (Auditable User)) +getCurrentUser = do + (_, _, user) <- R.ask + return user + data ValidationResult = Valid | Invalid deriving (Eq, Show) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 057d343..69b630c 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -139,6 +139,38 @@ roleTable = Table "roles" (pRole Role { userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) +auditTable :: Table ( + () + , Column PGInt4 + , Maybe (Column (Nullable PGInt4)) + , Maybe (Column PGBool) + , Column PGInt4 + , Column PGText + , Column PGText + , Column PGJsonb + , Maybe (Column PGTimestamptz)) + ( + Column PGInt4 + , Column PGInt4 + , Column (Nullable PGInt4) + , Column PGBool + , Column PGInt4 + , Column PGText + , Column PGText + , Column PGJsonb + , Column PGTimestamptz) +auditTable = Table "audit" (p9 ( + readOnly "id" + , required "tenant_id" + , optional "user_id" + , optional "changed_by_system" + , required "auditable_id" + , required "auditable_table_name" + , required "summary" + , required "changes" + , optional "created_at" + )) + instance D.Default Constant TenantStatus (Maybe (Column PGText)) where def = Constant def' where From 79d51148775d1999192a98941e6d9ecc51d23580 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 17 Nov 2016 12:12:37 +0000 Subject: [PATCH 41/69] Test case for audit logs --- SpockOpaleye/app/Main.hs | 21 +++++++++++++++++++-- SpockOpaleye/src/OpaleyeDef.hs | 2 +- 2 files changed, 20 insertions(+), 3 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 32d3538..508328d 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -18,6 +18,8 @@ import Control.Monad.Writer import qualified Data.Text as T import Data.Time import Prelude hiding (id) +import Control.Lens +import CryptoDef data MySession = EmptySession @@ -38,12 +40,25 @@ main = do runAppM :: AppM a -> Connection -> IO a runAppM x conn = do - (item, lg) <- runReaderT (runWriterT x) (conn, Nothing, Nothing) + user <- getTestUser + (item, lg) <- runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) putStrLn lg return item getTestTenant :: Tenant -getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" +getTestTenant = Tenant (TenantId 44) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +getTestUser :: IO User +getTestUser = do + Just password <- bcryptPassword "adsasda" + return $ User (UserId 27) tz tz (TenantId 44) "John" password (Just "2342424") (Just "asdada") UserStatusActive where tz = UTCTime { utctDay = ModifiedJulianDay { @@ -63,6 +78,8 @@ app = do case result of Valid -> do newTenant <- runQuery $ runAppM $ createTenant incomingTenant + let updatedTenant = newTenant & firstname .~ "Jake" + runQuery $ runAppM $ updateTenant updatedTenant json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 69b630c..5122d02 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -159,7 +159,7 @@ auditTable :: Table ( , Column PGText , Column PGJsonb , Column PGTimestamptz) -auditTable = Table "audit" (p9 ( +auditTable = Table "audit_logs" (p9 ( readOnly "id" , required "tenant_id" , optional "user_id" From f02c93a5070272e5cde050d218630620dc205a18 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 18 Nov 2016 09:16:02 +0000 Subject: [PATCH 42/69] Fix build issues --- SpockOpaleye/SpockOpaleye.cabal | 11 ++++++++--- SpockOpaleye/src/Lib.hs | 9 --------- SpockOpaleye/stack.yaml | 2 +- 3 files changed, 9 insertions(+), 13 deletions(-) delete mode 100644 SpockOpaleye/src/Lib.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index ac7efde..cfc96e5 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -15,8 +15,7 @@ cabal-version: >=1.10 library hs-source-dirs: src - exposed-modules: Lib, - DataTypes, + exposed-modules: DataTypes, ApiBase, TenantApi, UserApi, @@ -24,7 +23,8 @@ library OpaleyeDef, CryptoDef, JsonInstances, - Validations + Validations, + TH build-depends: base >= 4.7 && < 5 ,product-profunctors ,profunctors @@ -36,9 +36,12 @@ library ,text ,lens ,mtl + ,transformers + ,time ,vector ,Spock >=0.11 ,aeson + ,unordered-containers ,template-haskell default-language: Haskell2010 @@ -51,8 +54,10 @@ executable SpockOpaleye-exe , SpockOpaleye , Spock >=0.11 , mtl + , transformers , lens , text + , time , bcrypt , vector , aeson diff --git a/SpockOpaleye/src/Lib.hs b/SpockOpaleye/src/Lib.hs deleted file mode 100644 index d7e3b6b..0000000 --- a/SpockOpaleye/src/Lib.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -module Lib - ( - ) where diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index bf15b27..abb7d38 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -67,7 +67,7 @@ extra-package-dbs: [] # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +extra-lib-dirs: [/usr/lib] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor From a995b2d5bd5e725d10b5f2646d4b61cf3d970c14 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Sun, 20 Nov 2016 08:26:18 +0000 Subject: [PATCH 43/69] Fix typo in TH function name --- SpockOpaleye/app/Main.hs | 6 +++--- SpockOpaleye/src/ApiBase.hs | 6 +++--- SpockOpaleye/src/TH.hs | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 508328d..ad7f8c3 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -57,8 +57,8 @@ getTestTenant = Tenant (TenantId 44) tz tz "tjhon" "John" "Jacob" "john@gmail.co getTestUser :: IO User getTestUser = do - Just password <- bcryptPassword "adsasda" - return $ User (UserId 27) tz tz (TenantId 44) "John" password (Just "2342424") (Just "asdada") UserStatusActive + Just password_ <- bcryptPassword "adsasda" + return $ User (UserId 27) tz tz (TenantId 44) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive where tz = UTCTime { utctDay = ModifiedJulianDay { @@ -79,7 +79,7 @@ app = do Valid -> do newTenant <- runQuery $ runAppM $ createTenant incomingTenant let updatedTenant = newTenant & firstname .~ "Jake" - runQuery $ runAppM $ updateTenant updatedTenant + _ <- runQuery $ runAppM $ updateTenant updatedTenant json newTenant _ -> json $ T.pack "Validation fail" Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index ec91607..c5d5a93 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -23,9 +23,9 @@ import TH import Data.Aeson (Value(..)) import JsonInstances () -makeAudtableLenses ''Role -makeAudtableLenses ''Tenant -makeAudtableLenses ''User +makeAuditableLenses ''Role +makeAuditableLenses ''Tenant +makeAuditableLenses ''User auditLog :: String -> AppM () auditLog = tell diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 9902177..5526120 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -29,8 +29,8 @@ getType tn = do TyConI (TySynD _ _ tpe) -> return tpe _ -> error "Not a type syn" -makeAudtableLenses :: Name -> Q [Dec] -makeAudtableLenses tq= do +makeAuditableLenses :: Name -> Q [Dec] +makeAuditableLenses tq= do a <- getType tq let type_segs = reverse $ getTypeSegs a let n = typeToName $ head type_segs From 4a3826832ab4fe249f44bd7f1934476aa8b500a7 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 21 Nov 2016 14:17:43 +0000 Subject: [PATCH 44/69] Adding comments --- SpockOpaleye/src/DataTypes.hs | 1 - SpockOpaleye/src/TH.hs | 6 ++++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 5234f00..fd772be 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -65,7 +65,6 @@ data TenantPoly key created_at updated_at name fname lname email phone status ow 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) diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 5526120..2af83d6 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -29,6 +29,12 @@ getType tn = do TyConI (TySynD _ _ tpe) -> return tpe _ -> error "Not a type syn" +-- This will generate lenses that can operate on +-- models wrapped in Auditable wrapper. The setters +-- thus generated will also take care of capturing the +-- audit log diffs and store them in the _log fields of +-- the Auditable wrapper + makeAuditableLenses :: Name -> Q [Dec] makeAuditableLenses tq= do a <- getType tq From 14e2d8a48116a933e380392ebf8f45072ce5137b Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 25 Nov 2016 13:23:58 +0000 Subject: [PATCH 45/69] Ammende TH functions to take types that are not sysnonyms into account --- SpockOpaleye/src/TH.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index 2af83d6..efb8158 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -27,7 +27,7 @@ getType tn = do info <- reify tn case info of TyConI (TySynD _ _ tpe) -> return tpe - _ -> error "Not a type syn" + _ -> return (ConT tn) -- This will generate lenses that can operate on -- models wrapped in Auditable wrapper. The setters @@ -35,6 +35,8 @@ getType tn = do -- audit log diffs and store them in the _log fields of -- the Auditable wrapper +-- Inspect a name: $(stringE . show =<< reify ''DataTypes.Role) + makeAuditableLenses :: Name -> Q [Dec] makeAuditableLenses tq= do a <- getType tq @@ -49,7 +51,10 @@ makeAuditableLenses tq= do mkInstanceDef rec_name t_type type_params type_segs (field, typ) = do let resolved_type = resolve_type typ type_params type_segs let fname_rt = (drop (1+(length rec_name)) $ (toLower <$> field)) - Just fname_ap <- lookupValueName fname_rt + tx <- lookupValueName fname_rt + let fname_ap = case tx of + Just x -> x + _ -> error (show fname_rt) expr <- mkInstanceFunction field do let tc = "Has" ++ (uc_first fname_rt) @@ -63,11 +68,10 @@ makeAuditableLenses tq= do uc_first (x:xs) = (toUpper x):xs uc_first [] = [] resolve_type :: Type -> [Name] -> [Type] -> Type - resolve_type t@(ConT _) _ _ = t resolve_type (VarT n) tp ts = case (elemIndex n tp) of Just idx -> (ts !! (idx + 1)) _ -> error "Unknown type variable" - resolve_type _ _ _ = error "Should be a type variable or a concrete type" + resolve_type t _ _ = t getTypeParams :: Name -> Q [Name] getTypeParams t_name = do From 4ce8966aeaff72f91e3ce3d13f71d7618d76dabd Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 29 Nov 2016 13:59:15 +0000 Subject: [PATCH 46/69] Added schema files --- SpockOpaleye/app/Main.hs | 6 +- SpockOpaleye/db/bootstrap.sql | 2 + SpockOpaleye/db/schema.sql | 220 ++++++++++++++++++++++++++++++++ SpockOpaleye/src/DataTypes.hs | 2 +- SpockOpaleye/src/Validations.hs | 22 +++- 5 files changed, 241 insertions(+), 11 deletions(-) create mode 100644 SpockOpaleye/db/bootstrap.sql create mode 100644 SpockOpaleye/db/schema.sql diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index ad7f8c3..daa46cf 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -46,7 +46,7 @@ runAppM x conn = do return item getTestTenant :: Tenant -getTestTenant = Tenant (TenantId 44) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" +getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" where tz = UTCTime { utctDay = ModifiedJulianDay { @@ -58,7 +58,7 @@ getTestTenant = Tenant (TenantId 44) tz tz "tjhon" "John" "Jacob" "john@gmail.co getTestUser :: IO User getTestUser = do Just password_ <- bcryptPassword "adsasda" - return $ User (UserId 27) tz tz (TenantId 44) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive + return $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive where tz = UTCTime { utctDay = ModifiedJulianDay { @@ -81,5 +81,5 @@ app = do let updatedTenant = newTenant & firstname .~ "Jake" _ <- runQuery $ runAppM $ updateTenant updatedTenant json newTenant - _ -> json $ T.pack "Validation fail" + Invalid err -> json $ T.pack ("Validation fail with " <> err) Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/db/bootstrap.sql b/SpockOpaleye/db/bootstrap.sql new file mode 100644 index 0000000..c841afa --- /dev/null +++ b/SpockOpaleye/db/bootstrap.sql @@ -0,0 +1,2 @@ +insert into tenants values (default, default, default, 'BTenant', 'B', 'Tenant', 'tenant@hw.com', '2312342', 'inactive', null, 'bo-domain'); +insert into users values (default, default, default, 1, 'BUser', 'password', 'B', 'User', 'inactive'); diff --git a/SpockOpaleye/db/schema.sql b/SpockOpaleye/db/schema.sql new file mode 100644 index 0000000..5881d14 --- /dev/null +++ b/SpockOpaleye/db/schema.sql @@ -0,0 +1,220 @@ +-- +-- Tenants +-- + +create type tenant_status as enum('active', 'inactive', 'new'); +create table tenants( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,name text not null + ,first_name text not null + ,last_name text not null + ,email text not null + ,phone text not null + ,status tenant_status not null default 'inactive' + ,owner_id integer + ,backoffice_domain text not null + constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) +); +create unique index idx_index_owner_id on tenants(owner_id); +create index idx_status on tenants(status); +create index idx_tenants_created_at on tenants(created_at); +create index idx_tenants_updated_at on tenants(updated_at); +create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); + +-- +-- Users +-- + +create type user_status as enum('active', 'inactive', 'blocked'); +create table users( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,username text not null + ,password text not null + ,first_name text + ,last_name text + ,status user_status not null default 'inactive' +); + +create unique index idx_users_username on users(lower(username)); +create index idx_users_created_at on users(created_at); +create index idx_users_updated_at on users(updated_at); +create index idx_users_status on users(status); + +alter table tenants + add constraint fk_tenants_owner_id + foreign key (owner_id) + references users(id); + +-- +-- Roles +-- +-- TODO: Write a CHECK CONSTRAINT that ensures that permissions[] contains only +-- those permissions that the Haskell ADT can recognize + +create table roles( + id serial primary key + ,tenant_id integer not null references tenants(id) + ,name text not null + ,permissions text[] not null constraint at_least_one_permission check (array_length(permissions, 1)>0) + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp +); +create unique index idx_roles_name on roles(tenant_id, lower(name)); +create index idx_roles_created_at on roles(created_at); +create index idx_roles_updated_at on roles(updated_at); + +-- +-- User<>roles +-- +-- Join-through table between users and roles +-- + +create table users_roles( + user_id integer not null references users(id) + ,role_id integer not null references roles(id) +); +create unique index idx_users_roles on users_roles(user_id, role_id); + + +-- +-- Audit log +-- + +create table audit_logs( + id serial primary key + ,tenant_id integer not null references tenants(id) + ,user_id integer references users(id) + ,changed_by_system boolean not null default false + ,auditable_id integer not null + ,auditable_table_name text not null + ,summary text not null + ,changes jsonb not null + ,created_at timestamp with time zone not null default current_timestamp + constraint ensure_user_id check ((user_id is not null and not changed_by_system) or (user_id is null and changed_by_system)) +); +create index idx_audit_logs_auditable_row on audit_logs(auditable_id, auditable_table_name); +create index idx_audit_logs_tenant_user_id on audit_logs(tenant_id, user_id); +create index idx_audit_logs_created_at on audit_logs(created_at); +-- TODO: index on audit_logs(changes)? + +-- +-- Products +-- +-- TODO: Evolve this schema to have a "price on request" feature. Evolve this +-- say whether the comparison_price is computed automatically or manually set by +-- the user. +-- +-- TODO: do we need an is_deleted housekeeping column in every table? Is that +-- really required, given that we have an audit log? + +create type product_type as enum('physical', 'digital'); +create table products( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,name text not null + ,description text + ,url_slug text not null + ,tags text[] not null default '{}' + ,currency char(3) not null + ,advertised_price numeric not null + ,comparison_price numeric not null + + -- NOTE: Adding the cost-price as an optional column to make the JSON + -- responses dependent upon the persmission of the signed-in user. + ,cost_price numeric + ,type product_type not null + ,is_published boolean not null default false + ,properties jsonb +); + +create unique index idx_products_name on products(tenant_id, lower(name)); +create unique index idx_products_url_sluf on products(tenant_id, lower(url_slug)); +create index idx_products_created_at on products(created_at); +create index idx_products_updated_at on products(updated_at); +create index idx_products_comparison_price on products(comparison_price); +create index idx_products_tags on products using gin(tags); +create index idx_product_type on products(type); +create index idx_product_is_published on products(is_published); + +-- +-- Variants +-- + +create type weight_unit as enum('grams', 'kgs', 'pounds'); +create table variants( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,product_id integer not null references products(id) + ,name text not null + ,sku text not null + ,currency char(3) not null + ,price numeric not null + ,quantity integer + ,weight_in_grams integer + ,weight_display_unit weight_unit +); + +-- TODO: Do we need an index on variants(tenant_id) & varianta(product_id) +create index idx_variants_created_at on variants(created_at); +create index idx_variants_updated_at on variants(updated_at); + +create function check_weight_reqd_for_physical_products() returns trigger as $$ + declare + ptype product_type; + begin + select type into ptype from products where id=new.product_id; + if (ptype='physical') and (weight_in_grams is null or weight_display_unit is null) then + raise exception 'weight_in_grams and weight_display_unit, both, should be set only for physical products'; + end if; + + return new; + end; +$$ language plpgsql; + +create constraint trigger trig_weight_reqd_for_physical_products + after insert or update on variants + deferrable initially deferred + for each row + -- when ((new.weight_in_grams is not null) or (new.weight_display_unit is not null)) + execute procedure check_weight_reqd_for_physical_products(); + +-- TODO: Need a trigger-contraint to ensure that, if the product-type is chaged +-- to 'physical' then weights have been added to variants. This raises the +-- question about what is a better approach in DB design? +-- +-- 1. Different triggers for every such condition, or +-- +-- 2. One unified 'validation' trigger that will be fired anytime a row in +-- products, variants, images, or any other related table is created, updated, +-- or deleted? +-- +-- It seem (2) is more in line with the Haskell philosophy, i.e. +-- idempotent/stateless actions. + +create table photos( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + -- no updated_at on purpose + ,tenant_id integer not null references tenants(id) + ,product_id integer references products(id) + ,variant_id integer references variants(id) + ,file_size integer not null + ,file_type integer not null + ,file_original_path text not null + ,processed_styles jsonb + ,fingerprint text not null + constraint ensure_photo_reference check (product_id is not null or variant_id is not null) +); +create index idx_photos_created_at on photos(created_at); +create index idx_photos_fingerprint on photos(fingerprint); +create index idx_photos_variant_id on photos(variant_id); +create index idx_photos_product_id on photos(product_id); diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index fd772be..a96b864 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -38,7 +38,7 @@ getCurrentUser = do (_, _, user) <- R.ask return user -data ValidationResult = Valid | Invalid +data ValidationResult = Valid | Invalid String deriving (Eq, Show) newtype TenantId = TenantId Int diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 12d2fee..16b863c 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -9,7 +9,6 @@ module Validations where import Control.Lens -import Data.Maybe import qualified Data.Text as T import DataTypes import TenantApi @@ -17,12 +16,21 @@ import TenantApi validateIncomingTenant :: TenantIncoming -> AppM ValidationResult validateIncomingTenant tenant = do unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain) - return $ - if and [unique_bod, validate_name, validate_contact] - then Valid - else Invalid + let result = do + unique_bod + if validate_contact then Right () + else (Left "Firstname, Lastname, Email, Phone cannot be blank") + if validate_name then Right () + else (Left "Name cannot be blank") + return $ case result of + Right () -> Valid + Left err -> Invalid err 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 :: T.Text -> AppM Bool - check_for_unique_bo_domain domain = isNothing <$> readTenantByBackofficedomain domain + check_for_unique_bo_domain :: T.Text -> AppM (Either String ()) + check_for_unique_bo_domain domain = v <$> readTenantByBackofficedomain domain + where + v :: Maybe (Auditable Tenant) -> Either String () + v (Just _) = Left "Duplicate backoffice domain" + v _ = Right () From 4b3fca4748d93035f3e03aa3892be5bcbd26c941 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 30 Nov 2016 09:32:41 +0000 Subject: [PATCH 47/69] Added list tenants endpoints for load testing --- SpockOpaleye/app/Main.hs | 4 ++++ SpockOpaleye/src/ApiBase.hs | 10 +++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index daa46cf..3237d2c 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -40,6 +40,7 @@ main = do runAppM :: AppM a -> Connection -> IO a runAppM x conn = do + putStrLn "request" user <- getTestUser (item, lg) <- runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) putStrLn lg @@ -70,6 +71,9 @@ getTestUser = do app :: SpockM Connection MySession MyAppState () app = do + get ("tenants") $ do + tenants <- runQuery $ runAppM $ readTenants + json tenants post ("tenants/new") $ do maybeTenantIncoming <- jsonBody case maybeTenantIncoming of diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index c5d5a93..700067d 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -38,13 +38,13 @@ removeRawDbRows table matchFunc = do createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) => Table columnsW columnsR -> [columnsW] -> AppM [haskells] createDbRows table pgrows = do - auditLog $ "Create : " ++ (show pgrows) + --auditLog $ "Create : " ++ (show pgrows) conn <- getConnection liftIO $ runInsertManyReturning conn table pgrows (\x -> x) updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Table columnsW columnsR -> Column PGInt4 -> columnsW -> AppM columnsW updateDbRow table row_id item = do - auditLog $ "Update :" ++ (show item) + --auditLog $ "Update :" ++ (show item) conn <- getConnection _ <- liftIO $ runUpdate conn table (\_ -> item) (matchFunc row_id) return item @@ -60,7 +60,7 @@ createRow ::( D.Default Constant incoming columnsW, D.Default QueryRunner returned row) => Table columnsW returned -> incoming -> AppM row createRow table item = do - auditLog $ "Create : " ++ (show item) + --auditLog $ "Create : " ++ (show item) currentTime <- liftIO $ fmap pgUTCTime getCurrentTime let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) fmap (head) $ createDbRows table [itemPg] @@ -76,7 +76,7 @@ updateRow :: ( ) => Table columnsW columnsR -> haskells -> AppM haskells updateRow table item = do - auditLog $ "Update : " ++ (show item) + --auditLog $ "Update : " ++ (show item) let itId = item ^. id currentTime <- liftIO getCurrentTime let updatedItem = (putUpdatedTimestamp currentTime) item @@ -139,7 +139,7 @@ removeRow :: ( , HasId columnsR (Column PGInt4) ) => Table columnsW columnsR -> haskells -> AppM GHC.Int.Int64 removeRow table item = do - auditLog $ "Remove : " ++ (show item) + --auditLog $ "Remove : " ++ (show item) conn <- getConnection liftIO $ do runDelete conn table $ matchFunc $ item ^. id From 82d2d7889d65f6d2c4e7827c4a2f8291cf0a0e2c Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 5 Dec 2016 18:31:49 +0000 Subject: [PATCH 48/69] Send mail via sendgrid --- .gitignore | 1 + SpockOpaleye/SpockOpaleye.cabal | 9 +++++++++ SpockOpaleye/src/Conf.hs.template | 6 ++++++ SpockOpaleye/src/Email.hs | 18 ++++++++++++++++++ SpockOpaleye/src/Sendgrid.hs | 6 ++++++ SpockOpaleye/stack.yaml | 3 ++- 6 files changed, 42 insertions(+), 1 deletion(-) create mode 100644 SpockOpaleye/src/Conf.hs.template create mode 100644 SpockOpaleye/src/Email.hs create mode 100644 SpockOpaleye/src/Sendgrid.hs diff --git a/.gitignore b/.gitignore index a4ee41a..f3f3425 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ cabal.sandbox.config *.eventlog .stack-work/ cabal.project.local +Conf.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index cfc96e5..c792759 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -24,13 +24,18 @@ library CryptoDef, JsonInstances, Validations, + Email, TH build-depends: base >= 4.7 && < 5 + ,smtp-mail + ,mime-mail ,product-profunctors ,profunctors ,bytestring ,opaleye ,time + ,old-time + ,network ,postgresql-simple ,bcrypt ,text @@ -51,6 +56,10 @@ executable SpockOpaleye-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: base , postgresql-simple + , mime-mail + , smtp-mail + , network + , old-time , SpockOpaleye , Spock >=0.11 , mtl diff --git a/SpockOpaleye/src/Conf.hs.template b/SpockOpaleye/src/Conf.hs.template new file mode 100644 index 0000000..34f20b6 --- /dev/null +++ b/SpockOpaleye/src/Conf.hs.template @@ -0,0 +1,6 @@ +module Conf where + +import Network.Mail.SMTP + +apikey :: Password +apikey = "--sendgrid-api-key--" diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs new file mode 100644 index 0000000..e0ad8d4 --- /dev/null +++ b/SpockOpaleye/src/Email.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Email where + +import Network.Mail.SMTP +import Network.Mail.Mime + +import Sendgrid (apikey) + + +testmail :: IO () +testmail = do + let address = Address { addressName = Just "Sandeep.C.R", addressEmail = "sandeepcr2@gmail.com"} + let mail = simpleMail' address address "test mail" "test content" + sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail + return () + + diff --git a/SpockOpaleye/src/Sendgrid.hs b/SpockOpaleye/src/Sendgrid.hs new file mode 100644 index 0000000..e1b5342 --- /dev/null +++ b/SpockOpaleye/src/Sendgrid.hs @@ -0,0 +1,6 @@ +module Conf where + +import Network.Mail.SMTP + +apikey :: Password +apikey = "SG.8vGgg7RVTKG4diEAPYjRLg.ZPR7XUU6YRD1kU8FM5vMp0l6gsi1tEsvApsjLtSjd4Y" diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index abb7d38..427fa3f 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -46,7 +46,8 @@ packages: - reroute # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: + - SMTPClient-1.1.0 # Override default flag values for local packages and extra-deps flags: {} From 69f172f87c543537fb4756effd4da9fbb5bbc2c2 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 7 Dec 2016 08:40:47 +0000 Subject: [PATCH 49/69] Added email templates and linked mail sending from create tenant json endpoint --- SpockOpaleye/SpockOpaleye.cabal | 3 + SpockOpaleye/app/Main.hs | 2 + .../email-templates/tenant-activation.tpl | 326 ++++++++++++++++++ SpockOpaleye/src/Email.hs | 32 +- SpockOpaleye/src/Sendgrid.hs | 6 - 5 files changed, 354 insertions(+), 15 deletions(-) create mode 100644 SpockOpaleye/email-templates/tenant-activation.tpl delete mode 100644 SpockOpaleye/src/Sendgrid.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index c792759..3004033 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -24,10 +24,12 @@ library CryptoDef, JsonInstances, Validations, + Conf, Email, TH build-depends: base >= 4.7 && < 5 ,smtp-mail + ,here ,mime-mail ,product-profunctors ,profunctors @@ -56,6 +58,7 @@ executable SpockOpaleye-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: base , postgresql-simple + , here , mime-mail , smtp-mail , network diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 3237d2c..4380761 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -8,6 +8,7 @@ import Database.PostgreSQL.Simple import DataTypes import JsonInstances () import TenantApi +import Email import Validations import Web.Spock @@ -82,6 +83,7 @@ app = do case result of Valid -> do newTenant <- runQuery $ runAppM $ createTenant incomingTenant + liftIO $ sendTenantActivation (newTenant ^. email) "Click here" let updatedTenant = newTenant & firstname .~ "Jake" _ <- runQuery $ runAppM $ updateTenant updatedTenant json newTenant diff --git a/SpockOpaleye/email-templates/tenant-activation.tpl b/SpockOpaleye/email-templates/tenant-activation.tpl new file mode 100644 index 0000000..8c90bf6 --- /dev/null +++ b/SpockOpaleye/email-templates/tenant-activation.tpl @@ -0,0 +1,326 @@ + + + + + + Simple Transactional Email + + + + + + + + + +
  +
+ + + Activation Email. + + + + + + + + +
+ + + + +
+

Hi there,

+

This is the activation link that you can use to verify your email.

+ + + + + + +
+ + + + + + +
Click here to activate
+
+
+
+ + + + + +
+ 		 
+ + + diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index e0ad8d4..3413ba1 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -1,18 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Email where -import Network.Mail.SMTP +import Network.Mail.SMTP hiding (simpleMail) import Network.Mail.Mime -import Sendgrid (apikey) +import Conf (apikey) +import Data.Text +import Data.String.Here - -testmail :: IO () -testmail = do - let address = Address { addressName = Just "Sandeep.C.R", addressEmail = "sandeepcr2@gmail.com"} - let mail = simpleMail' address address "test mail" "test content" +sendTenantActivation :: Text -> Text -> IO () +sendTenantActivation to_addr activation_link = do + let from = Address { addressName = Just "Sandeep.C.R", addressEmail = "sandeepcr2@gmail.com"} + let to = Address { addressName = Just to_addr, addressEmail = "saurabh@vacationlabs.com"} + mail <- makeMail from to + --mail_with_attachment <- addAttachment "Test attache" "tips.txt" mail sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail return () - - + where + makeMail :: Address -> Address -> IO Mail + makeMail from to = simpleMail to from subject text html [] + subject = "Registration Email from abc.com" + text = [iTrim| +Hi, + Thank you for your registration. You can login +at www.abc.com using your username and password. +Hope to see you soon. +Regards, +abc.com|] + html = [template|email-templates/tenant-activation.tpl|] diff --git a/SpockOpaleye/src/Sendgrid.hs b/SpockOpaleye/src/Sendgrid.hs deleted file mode 100644 index e1b5342..0000000 --- a/SpockOpaleye/src/Sendgrid.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Conf where - -import Network.Mail.SMTP - -apikey :: Password -apikey = "SG.8vGgg7RVTKG4diEAPYjRLg.ZPR7XUU6YRD1kU8FM5vMp0l6gsi1tEsvApsjLtSjd4Y" From aa38a202cd6cc4c0a890802d51a3f605ff7ac7de Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 7 Dec 2016 14:06:33 +0000 Subject: [PATCH 50/69] Add inline attachment embedding using cid method --- SpockOpaleye/app/Main.hs | 7 +- SpockOpaleye/apple.png | Bin 0 -> 40189 bytes .../email-templates/tenant-activation.tpl | 1 + SpockOpaleye/src/Email.hs | 79 ++++++++++++------ 4 files changed, 56 insertions(+), 31 deletions(-) create mode 100644 SpockOpaleye/apple.png diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 4380761..0a22d62 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -8,9 +8,9 @@ import Database.PostgreSQL.Simple import DataTypes import JsonInstances () import TenantApi -import Email import Validations +import Email import Web.Spock import Web.Spock.Config @@ -19,7 +19,6 @@ import Control.Monad.Writer import qualified Data.Text as T import Data.Time import Prelude hiding (id) -import Control.Lens import CryptoDef data MySession = @@ -83,9 +82,7 @@ app = do case result of Valid -> do newTenant <- runQuery $ runAppM $ createTenant incomingTenant - liftIO $ sendTenantActivation (newTenant ^. email) "Click here" - let updatedTenant = newTenant & firstname .~ "Jake" - _ <- runQuery $ runAppM $ updateTenant updatedTenant + liftIO $ sendTenantActivationMail newTenant json newTenant Invalid err -> json $ T.pack ("Validation fail with " <> err) Nothing -> json $ T.pack "Unrecognized input" diff --git a/SpockOpaleye/apple.png b/SpockOpaleye/apple.png new file mode 100644 index 0000000000000000000000000000000000000000..406679dcc6b2785a1142103c65279cafa743de93 GIT binary patch literal 40189 zcmXt9Wmr`2)83#P1nCCp2Bll+l#oVg5b2IxK%_*vQ&L)5au)%SMnGv6N$JjAc3*z~ z>v}((^J&iW%-l0`-?OuE`nqbw1at%d0DxFSUDXf(06x3|0eCnM4@>VajsO4)Ktol@ zC@}w^C+I8Zu;1$SXl>`HMey;inQ%7n!+e|rfCz{Or-x#x$8+ErmeD+Rc}2)+{$|Si z6)PWu=>5;)B?8UYT14hbGRo>qFCR^)nM z*GF|@8w#R&f2umKFGXjNU6mV`b(}T4e0-Auy*}Pi(fszTgl0dLA2%ic_bQ{loHzkj zemtGk>L=?-ed4&L180PXuaSMFmIO0^<%v<-Dg6vEC9|F_2Oxm3gU8;zAPU|O$Aw-e zQ$j991;ZF_eAGzJ=OxBg-T5y6v*llJUyf;p7lGx~o6eqdV7P*ofU6NcB&}9#r+#oD zAR?saEKFuN63D;VIl3rK3RJ*G;dxFKCYUW1#Ecjd?ThpWj}fXC!aL9=`OCIIzIN{4tR&>)i7{e`r%{@AbgUPv+!+s)o6Xru<1Jujm9tm}-TY z_ziC9)S~;zpU2`+u(1-X^YWTLDyus0p$2$HHvyp0mM_gLoQP1**E~`qgB9I&_p9Fo zb?5y)<~xJf_{1@G+P#9)Ml!GBjWwQ5R&WUG!wl-;aK`6mW61~@42mCCVD8L%01 z*4C4lnbC?eRr1oZi|eq6r#w-ALu7FLWPl}(Q@!zZK#DoBu65;Hw}AbBk#cQnn_yj| zh8AIcNEYagvf5ZVu#p>>_M{e3{`mc9MFN*pu-OTd-Rb|HMf)j8C#|;onxu-s8jG26 zLMlICfcrfQ56P5#xb`0VR{)eR85_XAS^aZST0z_OQwUWVybv(j??7_UnU?X(T3P)Q zrXWD@JRa%a9B@pt!;q$7E1ejNRn2>gVT)8>^k?!M4mi=x)@2uY!NEDpPZY88Z0)y) zix~i}Y@JzK*PK^&qfj;UhUAFxmE6E;hKl;d08PhEp;h-4F>(P0!6$E8zfKS5h?Ru1 zvkh=_;{CJiytbbvD`lbR^M;N|KlZ-;FQDD_W)?e2YjZ!9@eYk$5psU z`Z|wUFv$*B1=N9t*PrR|$0MY#<5+*<%}3I(vr1cj#t6HBW;Dju$WjC!u1WA8(t|V} z{5J%(VV!wLezNN0IahFC(UCBv`hk5&#RHZ#2Sc+&ML3D#zh{|k?UzdOF$sFKl_X+z zFM0AUxfV7#k`y)kLIrOa8yZXYwk>zx1kfJG4|oVLzuP{FfoC3bqGb3xC1kT6xH zSS&jC(NFMgKcSBnmX85nlSeaUHIGf9u+Kv!93zmqRnv8QMPtI_a738wO{PlVv2$*$ z&!^Yei2+h%U(ylm6p7PFhQHTF8EZJ?h;OrA@V;%wetW($5=C84RUe@zWd@Oi9iaar zB&hZ0PgR5sHoA%FQ3SXK_nX}{pG(DebQF8YkYmCB-Gp^de|0u#PmBA-%z18 zN{=e4c!cG4Xb7p-;{R8p7;dRPo`IJ;cHUhHAarK1R?$~oftU~*4XYr!H%#?}$+eJ0 zowqD6Uav9Egz9qO-Zc&CnJC= z5L}}7&;k~fBff&w|ozfh=D__N${3Cu9>d*8QFfo zkqRf8Ou?foSev3t8&>b`d}eiHX#qyJ1*1UN^toQLrev6R+O8v@a^#qX=)KEwOX)(d zmmebBDHisN_SMgE9=H8&+?$wAW^9rp>4DxY8GP0gbj#e)0b?9rbWjrc`wDdEWI_F0m)qA zgv8TxjxSpmOxlBFdN`()HooaH>7>+B7y=4CLmynLVV!;--Vyrh^)A;8M1&*EWGdeD zJl5b6^60S-sF(6TSZxn0u;`3vP`;u)T%S4$$k7tP6lQ2m`u4O)|j-Q;>HxcR_Y)qdRpJ+cF9lt{?oKi*YSNI!eYP9}~SX zLC2N_VJz+K?7sUTWb-OOqYa9@R@HWOud}1r?pJbL4OnynT!^Tf|1zxs?uO1#zYH^E zhcr+GL?g%iCkXI3_2I6hX-mjb_?dGCxa;V(sCyt%=6JoeVR@)b=In@5T^T5oq?T@f z8Kp{xugWatm!C_W67$K_%q>wQ#VU*MfIs-0QHu?nj7Ef2NVW|eju(IN!_+|r2u%XB^PA$7pMUJXKPrNdr>I-?duHd}XJ+y~ z*wlFxcr;)ZYT@=kNxY0j+g1Ln61OxbCMyfDeUkjy0|abfiMbo;@ErBI6}@+!05^JH z91i)26{nA{7j`LLY5fiE`HzN#C(|YhGRdgWzmTY-g@FV#ik^(7VFM0qhx%PC$nOe zcYF(|A6gU3%FqW(zPH>#%6e+9R|(`t9Zu99!7IQDQ`VEYL=>S;ddW?yQn5=#=+?}T z%M(^y)J4OHqWJK&;}v@Kg?+6gPFItJo@{vkr8Lo$dk5!<>4t~A-5kZ z3-F?{97y~+?i->&>Yy_{>&@t$2@&fDnqog{BgPc+K_#i-@4j9E|7g6!Ep@^vM#$zN zoGK3P1u+rF5oJb5lPmULKG!QXp-VMa)|~rAnKznB3e)1RQ>BsbX}qi@(I_b<%-Qhr zuOX^MSj#4DB7;^9)uci|;f`*%`fqcL9lXINgXqZfA^RsXU|3RT3a{QcbW^ANY=>Qv z;MB8O*KVLW?Vp}xMTQx?CrjN5P<<-&_HA<7Pz^ehCy+3zFAT+YZh*HM-!3Sbn z>~L0~>+yobsv2Gdu60*Z#_NK+1(}fpxnj*Q5lZI_Yskwyh;6RvDZU7q@);6#_dAUt zY)_nz&-fHMWLK1d5TlWLDumUGy0p8;y`N!^xxF(MNMz)HKzGhrRC2m+P)nYYL)5*PWVOS^ z*In=E(FoEv7ko3;>u)0)U=zFNU1zgNn{)GCb5)X_SFD2v{kx_Cfa@m~KP3PhMDI?P@a{GlSJsmag*XUZ7esat~^b~ifNB$6ZQ?DmftfZ5E=7$M1c zfUxW>fFs(9uHFy{>^B(fi{jHh6JJ_IcB3*!#jc-VATj`M1ISNzR8@~n7&`uEG@%9R zS7qV$^6mKgHQ!-_o0{AR^kqozMY)}9*unD}R302*-Ga0Ud%zw^YOCK5cz-8M*7C(b zqX&Yb|Mj3R-MOJPd5XAIfQ*+DJy!nZecEJ_|3ykmum>K{($>dk$z{n!o=iZ zrF6mhQA&qWSIgM)nBO~ZlN6vfvfkNxR{LiQasN4nvw?l`W~0Z><(nquYecV?b-I|L zaqrl#qQ`s56yPanu>**6G3nD$!T`O7>ZfLU^W~P`;DHVAkoq>+L=Kubfea zosZawT9M3%iCF7+IE)ZwI#&br&wU`0PQxm2eXI|c$x0Fx)eIq5Nrd-$T7J8(avD+= zfNWyCii%!wdu~noLuzW5wu;d0q@s=aMjw75i>>RNtF9|rNv8XQ83q}@2}2AQv`F6j zhSyKa^5@6@Szcn1*iOXdliZD^n+E3dfV6CVTtOI4Hu(&dp@Rs%>bpV@1-XnR; zzjFqK@K5FCWvJ4W%Ug@BhMM@vu)jgQ{uh#d7VLUJOkYZW!ftOv`Tq>(`Pvzg0w>ST z0OZ-)4}#`>a^~*4x!q49kpPj{Clg||Ly|?o%T*W~Z&lSlH;^QDD$^vim7Q#8LGF-@|o?>l^T}i=6w6a z>A;*Wg^InT=4b#Z4&`W3EhKpLYkeT<^pWgYbg3%O2u!2oo*Bkk-uz#ilTkaGPE?ZM zHwY&;L_(aYdg-13;1L0a=?E7m=J)CVToKj6@H6pA2Dt>E@3yuXh*#(l5t@+h^H6lc z~`M8^Qd4-^=cPB3khHR)$DJJq4H*-pza&$p{#J!qYfo3B`Xjv^jDlVJ( z%_P``z^9(T%ud0;GgwL}I_=pPZU62Er0x8qIU7-s&+*-1!5Rib878n`j z^4caLwdC!09CiLoOIm2#b>%HeF5?%;aqlpM=a^%7$pR` z4=R)jC$Rav5>muwc8};d;{1<91K<*=t(Ob8k3BrI{_t@0Tuo%%-d4^~j`>V{?$D~a zGNgpzNBC4$J`_uhnfJ1KiUeyxMY*@rqSjQSqY@%GOvuIN(2d59AQk(F7!mu}$MKd(JyS_Xl}qZA_{)uuo?`K zZEl-zg0h#j9>IKx0iT=SXU39&v{h8uUTr0@iR;*Ipx!6?=oGR_Mgw0WfM52-zc{&A z0#lrieCFj3!DNdzT8W@5HvJcDlrA5{ox7ab6K0ti?lqr%s@;_{F0IJ zcfaUcf43%MlX>!p2La@pi_UdnNgozt!GSAnxv-z&6NNvzv58Q#;T^QH*kM|$VXIwj z-2YELf`p8M2o3dVxJZxl#m#PX z&jTCz?y%{iZFqJKcI)Uq{&ik3{NfxU%{1)t`!|@gac0)H{z%QfZ1Y-UIvko@iy|c5s1zJ@D5F2Q+U}@V11?%i`(Es$o}!vg!}BmjF|#ZX?N4NnWxf zb-M5TI$bzQAL9xKv!8I0gMML`h_etku7a4olf|6)f#2sMAUfv$Z`FLY7k>eg!9kG1 zmKUobK%s}(8UNy$_jp0T!QUg5m~Z<>-~+SO!Qy&aBe3$v_t{TiSkvp&*)ENCa|C7z z^o#0UvHQNw?r&^6spjXG*DgB5@@4(vH@Nh?t`34KW+;Ln1UHf=3J-l}!}O#VMiyPP z)a9GpQ)(*gLYMn+=jjV89cMfd7E#Vlo*Vr2XK}qeQpd*GTsrb?1vL=&0wh#H%e!1& z-M?J5#j?1XvA>T(YgFsw54#VS*?rEjK2&TZ)QlpA03&6V50*!)Ks6#t06PK2*`6vZ zFbHoq!sSQFhga^b;RI1SU$_Lc$mpiOm%<286Nh62{u}`Nz1v4{1S@F@F;Mw^dE?Ge z*Yzo!@A&U($k7|Wpy)-@_hjA!mIREycfY3lSLY=ISh&8A*QU?B+gbHX{miOY$4RVT zSr|l~{Z>~p3{5l%I{{6~LGqiO1X)1FgHKLm%Hr?h*kfD-Pggz2ZZ^DHJ3Ebz%Uzy` zvv#nu5vOPvh6Wf2Z4mLupDKVc!7@)$GtlgC(iCoVQ(=P332T(n;K-h!|Dm-*(3~Jn zsmN*wgFKJRqlE8i8B)X+pVY~e$;yWLNF4yNB6`}3c&v_4d|FA6i`iLrr;HZao3sn7 zY_=$YgbfRJu5)f#Y{+$D&|%H-_GLpy z5jf<^@HV~zUrO>1Z-7nQ4qpc`UYpxyEBwE)_U-ecG$5;T^)eeCiRIl&uCAp2x};i? zeE)D-Wh}Xs__+_f0f;$!v%g(ecTNbObeX8LEE8qG4JW-(&`=Z$c!zHFBT41IPkPPY zld1JlKjo%EuJBzIEzQSHd58-%fGf&6h>S$&#Q{-ifiyivYg1O{lF#6WnX2Zd?SvDN;%R40g+ zC{w?6f==!rCK;rb-Cu}bFX@;&Z>njGK&A@yB2;Ne+^!Cm`Xf|uUoA9i8qeX8bAi@7 z>kYI^NjNM{{(RSJJ2O;dWlR_*)=#jGtezH)R+r~`|H2L%pDbN2mg8Ef!o^C}3;1kx zprNook&6H;38(<+(thQ=1XipsRv<(T!6k8=*_OSA2#y2K!QE(y>qc4g68uJf#}t!( zjk%h^BO!>fV}F6&p}Tn^_C+7dVUF7a)oW*`WHEFzjf|5bct%V-DSyp?K>aY7C|DS{ z1z`b_(jv_<1c3vQeT&j6)BJtcDT~udK(5Q zG(R*wO=fy4Tl}-Uet?N=Yl$E}u8^Hha@vuXB?fRw-rsR&RtEkj-%h?7XH-iB7n zQTl01Hk&cU;@oKxi3@ty9gXlKfpwQFp5U(?KNOGBrHq+6mUan1ZQZ#XTmi?L3zWul zuqd(i8JBsj&jUg{y1|+2qII73ZTi_N?`>@nq8ypIS9$pE?h3tfKda6nKvNu~5$;;( z4OTUSav*3N@W^or6A3LIge|w8!X$8& zK_W};gC2FES=#|K<}Z@DU1nu8-EPlAyA~GP=dcWS^0}3NR;`P(fys6xefIeEAm`je zg;IUK6v&T?4j@^u?2FuoVVyaSEjSK0Vh%()eT-MmnTA-Aq9JkhKVInX1&5fe^dz{x zV%1Hp59u>4Q^2hsVgH0fqGlb!(jGg&{q0GX1LYe}fvqI6SqLc^9gjAPxRmwOz}r(+ z?X-mCH^88b^(P%*9(Qm2$TIiHGNc-I(t)*VBDJJvO0Zv)E5dA9xJ>c$N&6>;?EojY zjd6i?#{a@hVrX$2<$8Ji%`S(uz9;2b?_D@q_S3%FU^gI(hTE`}!Md4igG=p}2e8Be z+r0=He)4s>zXfXy5Lu40j}}rS$Cn~yZ3fYDK<>s8Dy6P2&KV$REPCoE1L{nD&z59P zHC0vE4Sudf%JJ3I9IQ4cScO~(Thr})9??=V`pz~!=7~D(QPIunLAF|J4^~jirH$HMgr>J zeYq|uUGxFUru3Cb^ID|gL#B{;6g2m9J$Jm8O zUccn-@Khde45UN|8o_d0i43n*l)l!dR=f{mOioL$a}U>s&{7_FtditNsqdu?Y%l2O z7D*0PJ*t!pxdY|V(+{(0*8gl%vC^BpoC4UGS~WYS(7T+Vp$&AePk8G_v&TkM56()GPMVEUg!EsYi=;A=xif zZh1zS^VG!>2iB%r2?(TOY3NwBA9ckhriWvR;Ifu(1}Z7T5Rm^Pkv=vw zLcIMidzOulNB;6-K(fpQO7vuo#q2)gckZ!u$RpC;TL~8BN4c|Mvk}IxGI~j+=`Y-@ zpg|(g7NM<0RoX6JL?;m=K>zDcuHVGmg3;6A*zCqPsIhEzY$f$29LfQFHl`fBwBh%| z+wTc?goGF7-?+JHiWNBK^0_COYlH_k%@+pii_s9#61^aLp|aPh+e~0wk9Et&X%mNpAJ<^Zac&wQ+mQ%^k%801WIUbT?{U}u%y2=ZXwD_?RdzWmoqCaN#4 zLkRf%_9cMjY2zzQMG6HCKd}GB$hE<VlFtQKWSiqO=t)B^=wvgjF&MEjIG6*7-yUc`A`p9xW#= zLdqc6Om=7`q#C<;FP}(6>9U}7b~+;$`T%D~V12dfY0b#r0#T56@pLQVdk2bT4!d97 z1dTP>LlRs92`oDqd#J@O$s^@4lDcUcdi26j9WXV-;yZ2l(?Ri28&c9#)O=2s&q# zKl>Z-HN+)OBW=TMVXtPJaQZZ=?sAUM98zen)DDagWS;_*yr>o6R@ayTMPZXAg7uHc zm-y))Pjv!E=#)Q1+24!dN&0*=(o^}^(X4frX!mhpdRuldwq@~Co8~5k#^&+>nPE{_ zfhK>z%L#N34s*?j0dZ=HDV33RD*c+F7PN-J`krW~X=#H1&p9NlWWC<^nyMV7dD)(R z#Dz_=aP3hsY~`FQd)>$3u11X3v2z67Wxa~(#C}Dle?rtK%o)eBQ0d$8?xrt&?~~ZK z41ri#5b7qSU)F0&0<}0QKnQT#4^6!13Stgv;1j zyFi?QUk;Z+URn#-b<^~7{VvI~8aTkkZ%RxZ|8RFhjd|#Q`oc1?0CZUV+KQs;o42?r zn*{$7Ii;{fa#5QeWKD=V#<0{PJ%c^Rv@w8DU#rGchFxRadlzkfr9RtSaMep<$`2Im z$p;fI+5mU*DUC;VIBIovBETF3EWfWw75)8PUDn~@v36tSS9MS=!#9h>_ z@cp*FbeCS;(hADK{FS$?=!i9fNfSkGP`wYqFh8eDwqzpUpV$zUblXpgl)R(g?O-bZ zmqzpSLw!0&$LeNhT4ebMRQ8<@zH;=(c7K_nq-Bh7lHBF+D08=;+-4^DA+5txXUCr5 zu_m%1KPPoZU-#Z$zMofs|^#3ApfTIsP4!Ybo)I ziqGvW{oSI;yIzalIP0BJ%*m;4A8$9Gve!vlN2WGhWxK`jQwJY;W#}y}1k8D1dNmdG z=@q~1wOA2r>{QSGt*riBKjV!sE+pt?ax8CP?2pj$;UeNr_%I8mF*2m=_2!X$CG#bJ ztzgqe?YXqgR)7vTqC8P1uxNE0--sYz9-Fn<%D-yJK$^=Cz!pZ|PbStNbYU${S7I~P zYMUo40W8;3(sz(p<(j&nGJ5^q1Lvow8@`Z&H>N*yqe|~=Fslm3ROcNJ;O7XY21?3m z+|7Ld8Ta&WQ=0F0A9;Smbk`mEq{!yaIkSx{59QE z9;+U-nwUSHYWnz{g9>k~ZH2n-{T;mfFdsXL;q6R|!x3hg$TTI?v#!ODWGpDAAru%@ ztxJxn)=XbDrNzS0C$4T;4rn{6UOQ|k>i~=Kec^qr-%)bl_ppJ{VMNQPwyIZb?6Myj z6i^A+4Xw$~;aoF+0rd%#6`-8@5#ddiUc2c`sQWg@k|Zeo9@R>yU)f}WlN=#7r25bU z%@tfVSjhG?bf_Tz&@s2$FN-$Mg$#)6tCvOp>*7ODh^|SvjZFAO4AUl~N2o;FFjn_k zsP@P)b`jO;qo%W(-=`Nr)F_yCD<9Kc+OzVHVd$;@;+hq9IY#7~MU6SBQl2a9eB0GT zr{8$AJ+By19J#3Girbo{dffcmbl=7)t9FFIreppVhs1P3%G=}3ihr^URg0nyNU~Cs zY3Vqf#&qcy-mn$?vld1SuguOpOH+){P|(LTz4zRL%a&2Nj6j7Bwlz4!+>HVM7i8<; zKV@zL?O1?K`Fm#E4+;mpzm2#_KnUftRCf?}}0 z8E2*XDCnTq0kounkl+sR4el}a4$;fYDjQf|45Me)fAY79%D5fwq(4>B{v9jd{LV6^ z*~ZE=i0Akq56LjzP`&A7>UXt)TNODM#5&daE+bsuVe8tgFX2qh^^IX5my!Bs^eTR# z|B@7s2r!8+e&_f2@blHiiSpL(R0>uly3t4Ci;Flu2?CzU;G`uRA#hH0*Pe%AX8mn-f-a)SQa9 z`CxAf=CT>cxU}_czvZ4rc2ST{_34d#uO4ZpdMYI^_u^z+0~Zm(u12{!OT-dzc54dn zVVlCbnd&D!DLB6O&#lnVJT|^nq4P9chQ|8n$QNb9;kdli=QhP7@%rmvRXeXbi?tCO zz8~h)7)U17SSLUr%Gv3W>#^}G)wYX6{C*#KO27wNE zgC)iSGE=k>HPVBiJ{XAEM1!>>g&E`r$28Mun@D%SY1g`{L`^6ACy%a8?dT+@<``O^H2lv zMN>~3!3&{oAmZ#&+wD==!`@xgP$-*y~8^Awv6ffmCSyZGT_X?(;HBgW5CNw z@;Uw!P3Yb@^?5tqa9y0vJIC7TYr@oJl2Gk>z%Bg_s*FZ;snam12q@m6zKBtZidxlJ z{ZPI|^`W%u=10P0FV7UpZhDzu&gz{xj^{)6sKJxK+D}g4VB`%UbJ(+}kxKt?y|x2Z zBx-n?)DqsMf3;+To%odd3&$c3Zdg_NpT&JZNzmio%YBJ)*$QF4l?~U{Loa&5;#XHk zTjg;=mA@T%jSWLqrD7^u@8U`->>PqTvruS?xa&{x_P<`{b?XOx=@|_VTMbawIXmTR zy^^=M{oYA&es%CY5iM7G= zoz*}DZs6TR2h4Hj9hFGSqX2lT6~Rb{la>N($A-|Tkok7E9J0yDUH0Qm^q&j7TH@*_mRh57mkVv!koM1yd10no z*Z5!gv`2~BU>`)myI4y)?MH?v1405nCYDx@Yf*{9M^2MH8)(uqdcCl-yHE7r zb}b*M&#EHbbl#7zrYFCS!}zX`5JSQ=ijiH#3g{Iw3H>t(2&+ht*XsmYCIgK2g zYOg3=O{ZMN^6jqy&OPndB#YIVjt70lgKSw9e~6NYv$&e$4%)f=MqQNs!J^!y#q_Ds zLOKogMA$4g1&bSU^1%bfoQc=H++Xw!qAABdN@Zs+QzcQKuno&xthw^sW992XANR1g zjT7d$Y>+M zdDe7F4bL+w@XtpkXz7#3>QN!RZif<~YXu&*cGB*FMWl@`ylHb}T>=EL-prxkX~h4@+K%2X)~nSqB_+Cswr zG^Gi)=Gy!Y-&pYHUr~9wd-U+)5-o*kLK}E5V6A5vZr+57#ojsv63${0MVatYB;Qv4ExXy>_k;6~ijA-Ck8GN#>c4SVuW&i#YT$O%TogN9#tbi# z#(etAT|oaS)cm>GBq_xsnk2pwRoz1A$%LJW<1P#sbzUi-qe4HY^zJFnNl~iP;Yu!i z-^K?@+H+j@R-*A$;?oxyG>V7QfL9ITum^SAkJb5yc@dsF8NctN-+)7>+SKaxDOWMA zuKs#aoJNd>!(xf|Ue+7|QlY;Wa?&cC?%Blx%N!}@wREezCcQOr{|MjkepwW$=$pLQ zCg-fijs1bbNPRp4+j7i<-ju~6Tyu7nI-ZFzEI_a#!^9EX9q!h)!I|RD}Q*q zT>!T31?{Ph$DCNNtmD6;g5i$yyx|@GJB&AN_<9-4lvrm6f1cl3kbO0{;Bf7$ zIl#fwr>3ia413~8<{4W?u0BE|UV`8)+n)+@Ki4C02ghfk`B?nQ6WJ-Z3u|-q(`A|8 zS>RqMXT>abUTpix7nU3e{&LsibF2hfMyV#PM|MDYoO+FVnT^{hupc-V24@nlXi}2PwyP z=APMkZq;zZ7&=@4P;n>BJ9S3s-u*C-wcjyEW8n(egZl?!dpEu@FD{Vbkm^8_+h(w7 z`it4D34?Vk5RaJq+@$RCSMExasaKyWC85S=L`Ko%zIn)t?7N#xbUR@B`z%qZv&YNA z1s8Ae4C^xy%LxRi~2u zL15g66@|$2wobCMEHpZ z^3BO;foFNe>i{S3-0*^P%E)<;O83vYRUdlS=C%-yyyj=Q*-rQQLm@m5LUT0iY z213oB)l60Obd2oiU^+oK9Tn<0L|JrsoTdsq5w)_#92TO;gqhv$3nBm8ShpzX?n0R9 z>t0Hv2aR$FL;knS%`aQ*60iMeA6hf+ymOl6SasnFW%>2RYlB6b(eAT0;lV7A;+;{{ zb4Eq29)M4owyUS{{us5wXB=w7AnNl%DCgzvX~&B7-xm}_t*^j%N=ZYq8RkH>0sw~t ze@R+4ho^z&vD-<`)m#)M=@&J3;jc`s{pB%Hxeb_I4f)I6N=cZ6gZ@j$uxf@PwnV>< zdhdSV8WOEVlFD90(I+I;i}~B$+(p+&-bNFQ5CzOO84Z#~ztu@#&T|cE@}+Wj$Sa?# z3moVm0!a+hnZ(Yn;iy(cQa{>Zo{HYqXjnRk#fl5{#D049^goKNf2sAh^nlo#-!sJU^4QE!zrHHFOG#(?OHy zERxLl)?snzrqCplv5Ln!+d!Y_iKP#z{YxLy1eVuD3F_JZ3yrRE4Yk^+rd;sZnyfsR z=IE%N>G^~vx6p%dK6~EgVJ`K=>FMohm;6r;>rE9Kv5wC~it^*&GKoDy*1G!dE5{@0 z>LD#(3}rMqy@Q02+FN<1r}?+h3j|IUxRe0pirWuAG>@~AS3u=0B#Cb;hc@M_qQmPm!dpNtpI;LN)t3**kYE7 zR|&n8d3`N3S}Twf#E!M!nlo@U#hvqrEblzJF3#%_=;xzBi4@iU+%il69XEB`E5WO6 zCbr~`!VPIJo)L4W|D5Z-xN5+h9FAzgqI+IHOO_5v?D1bc?)E+oqaSAcA%0U*a4SHT zkS>Lq-ZIB|Vl&|&JZJI<9O)3xNtn-Ji$^SbiZ6NT`@Q$wsW@D(Bj8NI6TI~S2$dbl zi+~Z8kv4k+u6jD2ZylluXfF74VQufS9IZRio_`O;pD5Uj9e2Ckb$S`>f=7%q7bd`m zrQ5uc=el3-wP;_6wU0Fz2^t5Q1|Kth`|_rS5x@GRP0_OEf8%_0Nkij|myv z-z**6kh?C=yW60Z!wDc{P|kP5l;$c+*L!@^2}()e1&?TtvZ>%Vo$)~O;_v>B2+|Df z$k;So`>Hd|C$-xqC3Idpm+$K{`j>5J#}R&WT`<~aAdcG{-nm*CfLLF$`4J|hC5R*1 z8HVk`FQ2htvU}N0M^hIfPaR<#+eMG;)-DIp-pFgM+Qz-3j*BW zv(O@bgTEprSYD>N$~df&(6qgbb*HS!?@HaEmVwY_SihAHpj|S3DQNQI1*;%7zjBiC zTU`5dN^c8@LmsY`_URz^NxpBnewwBgIfuxC9_`9kA>n+Q$tlyMDe?_BG> z2hAcP!%2MvGNVlzUP=SEQ8LZ-gQFkry~lR;as8c|2ok+fZePfZfL*h>8QA&K%Nz>i55B~!%a zXfn&Ri#HI+qaslNA<;ztGYn(*O|8tqwWwFPhAidKe>`eW{Q4n0h_ z@4cw0kvL1C)H&2Q`>pfeq^`*qeagWpKzwX>;^fCY&jg`u%1ZknBe?)LZSj{6CkNDP zH*?!Om{N`{$lL8P;!OHJfILBW^}%7tqZ^UKtd3X6uNjAwcGjFn%=<=0a$zjkUg}zl&LK&my?|S`7K)&a}VmW>Q{SuM{nC5_ZH|xY(=x@LN>uLm)uYxHJvl_x25^ z2BsTI_=B2T+`8(2MSNUe%;%7DN0=)GpiqP9`g||*@%q1$(;{tRLJoRYmz2OZrkndod`Z0r6)U*4M4+mVtRAsDeyu3;E+& zcsAic_yl8`c4UK3lkQX2?K_?0JwqZ9R#4#NHM1Givi0S9TJ(?)0wcPRJ_I^vE8!Mj zzM4GC+6@<1*p?g3CZPvIbqN)@aFW5{4l-b6W2J2PF9`1I<_6Tm{%*+8=ez(1+iz&1 zwV|KjyDxGF;c`_@S@Es$OIXz-;xfUS=57@uf+A7FvRVk3lisOA;j~It=C+%aP~5g2 zvjOkg)=z(;zlK>>s#Qo)FkWysL_fn|l81Xf;UZ+<58b;_z=Z{t`7;$IxP5Uc>P3f) zqAg|b`5YL$63{rvEL861kF>nEmIMDyY`Wfs03)Q$&^|-RaLh44A-tJS!BP#7tY-G) z7E?85dKCTlb0#`~cPBr7@pE-ssu_Vm&*5P$1Y=&F-uC^{rLyr!!Ns)P9KP&sv#*a# z`BCZ5Q8Ge2YBBmK&JPIFjG$jw00Z<3+2^(l-GJEP3ZI5rDw-?WY+v< znQDo*SALRqupOZxjNE?khD`NG(5v#wqR;5ILK79qTPy}hZ38L^fI-(4qddcCAO3o} z4>kJHWurz%B~q>;lR!#ZUTO8qqK>7v^{b|sRz8bqwXBG0JH@rYmh9jv4%Xd8+i}dI zVCC}*xnOPE`Vdd-Ud&i)Rv$>(WgxxIJh*Q8Y0+%}jw&VASP0)u#@Wb`slijXOG3~u zKH+U%SW^sWN_tY|0H}Oyu@IPu?dZqz*_2aM_)?&!zSx|0R6&Y#GQ7=Z#D?n^I`7ZU z@#rNMlo>GHPFweVq-J*-vKTKJ;yEEQ<`s3d6j>o`kqeqBcyFXecTvA#eoJ~Ksx>VETT+ZHz2w3KZZAwH2?^8ajSyf3=0RlY?oBRHnK3tSxfpo-6(vV97*SVWpa zk45vlaM#5O;K2wuQO~;!o5lNi-2HHV+!1vpi*QbxCsQ$EVHjeTwV5|DJB3ly%*VL* z=<1MIwQqx)!6H!HVLsGaLCl{gxmO?TcZ7{oKLS)q{YQ2cXrc7qQENOd&FTbZk>lEfU5H-r($>)`<%Fz(6;Co zE@=B|YF}NggAwW&sONA?|0*DUi4ml+#P$MrSEVxCb?{JvnFstYO7YZ(N_AU*y!X35YJ%za zG4j6PyeC8*0&}{TIfY6M)vLy{O?AlrpligfbHe;g-StJJe_0l9_>1IEZm+4j)0$VMEPicIVb*P` zFGc3Y^h51#+t2S0B}9*J{CC}R#-t#e+Hjov+4!Z$Ip0h8W3vMcuJqfe`ofR`cVk+? zL)*PwnR%}*GtVrN1)<9x#KO<0DcC)IRt>hXQ2DsQVd#4n38apINPic094Hd_zI z4kn^CR@-OFx!kW&1S4=}w=hTNCph$DG5sd$*wKX)3y#$!zxQV?%||{zMwoQU(adc3UU`;|x|2}#7{fjMyr0~tkA@aC9#q}T zR!4lWAlz}I%AAIP`m$Zv=<{@lb!V37lVZD`ajDjW;O_LQ-(}A8QA};|q$|Q5Zc1G} zEIXwrr`4q!Oy=U!E5!pO8pqzsIipB2#vm7sYFlV%S_wbza0OHrMVvDtFzw4KvLgb5 zb6`Mk>D$C3;4`dW3rQK+uY`q%L}Ik0|M|Yz<%rDukeRUP?(}~Een5f070=NBPScgG zc*d%9uIUE{`123Eo6v4cw~|E1`^O*7B;*W+`W1jQ7S>)xvynCafTlOMY8TAF2h zf!=64X1VUg9am}IcjyQH`rk#}1AV91V)Q&}Iivh0=vQX@G3j3XdU{0L?*G4V8^|>U zfIRm9As`{=_->;Jju}1e1@V*2Ne8B4d$X?1;eZ!Njj z4B$1uL4-u3Mt7%=Iiu08{Xl}Lz%~u-ueBl_YeidGJJM4~O($Ylfu)d!`ft}cNGrKu zwtHaEaSP@tzsX-;*I%v+pvU@5K&3x6Kr^6BpaU|P&yW?|nQx}9mVF2LAsgV8W z^q$?xP9F$hTgAVW8?aqaP|sbmSf3EV=rt6=(6y?7d3)s#L z=v)8ow)?RF%cSf8p&9TH+GbdNAH&RMvYZdZ-hSuPSs*q0g;~Yf?PBruS3h_kQ0>D? zfzi4w{TP4+g(?mDxp2(h;tcTn{kObT<$AaPNrrc10N6_VHU>~cEri*(pr8nDKWc}b z8nM7)mCw;urg@-X*+It@=qbPEryqSTwBK5L-L}^;=X`Jba%DR=VB4VGHVnX0Z({&f`L`XaZLg!PM|PznTyN43!vb(=mftf+ zp_y9x{}^y=&R4i4<(dJ2JjxIq{_BC^o>p1utVOpV{esRKe-TezHW}@0D3$T)q9ywz_G(eCyhN{kl-{rk39r5oiHGw?$INpKcjE z;vVV;EpA=8mJDDOxHo}+1%v&}4F3hXwMLcOS|R-)YDJ8c%jQ`m^BeW!n+nyZ_T_R@ zxjH_)wL=iIm7b8x$6*G^|F%z6E> z*YwLM|JMn$_AR`&0<^a%qeFX->pZtudCf!K_kH^Bq1l9U&-Sa`7rBk(S^~hm=*mCU zI1T?TfjWb{ol4t7Q*bS@ut* zckW`_o!7buAY6(8=>EKIdyly;L3x2~?qkl+izW1dc-wc9Is5$pV6Xga9Hmqp0~lS3 zn0~y*F0z7`;l4WH$MgfJa`WGG!{#~yo$i3Qx?DQ|7;!H!M1b)!Wld!3=37eEp=b1{ zsRah(sH5 z`o1==GY@07{KS+;pXTbXx#^suZp+%9>#;1?&x=iGfunETd(Wg-#vNcW;Ht-?3IxCc^i&DFa-d*1jh z(?3MNhD8H166?07TX~JrcPJbf6VSB;2(E9X%b#gOMv%U5S%Q6%yPVSAN7D*zTFVTk zc3;{@VvhA(*S6xDw05VDUGqTUqQI&}=w{QERhaYdz+R))lkRu$bJFxdd|qU>{~os7 z#O!M`UZct?rvFb40><1YppkYz6tX-6x6X85mm}8<0G|2-?gH4Fz^mR-vFFayFj0T8)I4nea48X55&%d#?^NlF zmF%;G9(^>wVgq>{<%YIH3ABSsY%`OI@ay>UXa}FzzkGYUufZtIPA_dY%iA5l4B6I# z8|BqqJ?`clGsQoXwv*nqzx`*;&6Ir~V}bRU!Q}F*mR=PeZvrV7xp{t7H^uFiD8p+k6F_t-rBvvhyP1(RZL1aS>F(w_yd_#m|e^Ac@|`9?Q@&s7$^yFm%?8aQRyCN%fMd=vwd9>bT zx4KXLF*?7Uxs^SMgr4=VPSg!k(X5ro-^Dpe zpQ1k@h}NByYObMdEsr^5E1#_Z9iQDOv-HlXFRGN)R^C##^m^*n8eVfNf_e4L< z99*0gdy#8*t%CLy9w-xKD61#~vLu185;VP6X$dg*wm?w6uYHE=DdZdgEFhXMSBej< z;#;uoxMuBfA$HHrD=+83#kr%CanNk`m|Bt(bMACY%e4f6-9m0r84kKi2DCK_S`AlP zE3}J8w8>R5C0AhAt#N9$@^&Ij!}v48WeV3Ssln zR}^~NC2zg+eL$F}?9eK;rgP?*O6#R}O|H`VA+AP0!y80fTIG$5bCQT$`UeFOGn@XQ`NT zK%#$5UoKT)=O%EoN%|A0lut58;WaOXAsA)1Heubn0sz+q0B9@O+)Cc7EQNOVE0OD77NIjP zpj2S#TA04FiNh(?oNHB#!Xs@3ELJI>*Za-*|NVWl)2H#aEViqR7n7bocaC>D-?(m? z5)`B@XKnG&ZB_UJxJKDKqcZ2^L+0dN%h9IMcQWeg{W!cY&mK=d(6a-(lIp@hM7gpzt)A>tg`@sD;FVk z#*iGKak^}mR3%0FX-nMUx;=MG<<-irK$7{XnEU9aKqvU8Y5MftTApI{HEn3~R^kE1 zt+4)mG|#q`$X2B7BKG+BH`Sv%?J8zy7^E-4p`}Bas?i+VxZsqS+ z%DDj6OY7zwv(mTBbBFqFb5s2UB_3ezQHYn!Ug}&|(QW?w@1e3?8~|EH*WeyP>`M9R$&7;+&V@b(EzK82Zo%NbxZE_{BE3 zt<2N!j^&ds7)bAYDP!F?mecj_VdDjz=g90m`|sR8)&aa;*_ZO4v)}13Wb)Smd-J{f zBOjIem-`##&%*?q0z)aEjw}G+CCQxTFeL7wfIZ<|uM! zThq@|`d+$%Yi7H{0($u>z_Cq!JKJ->qc8S&-)hgKm7a1NK$sW2o9WmC?aDe<%r_|R zL@$qh;40t7oR|sb8F00V-?@jhU~QWP3#jz!QBit~<#*~eaLk9cimIg* zEQ}w62|+J_HkMy53C+GS6==$>vh!E9Kfgb7Q;Wjv^<(>Eg52J>a?&P2lfPRihX#qc z|BGZ6=&ECLm`_*!3qfKSIBI+1uS<0g63u`CCX<-O z>g(=zR{&fG?EumHKOd4greDYOtdtF?!!aZ?o58Eqv4+}?0F75UEO(IHiPXWA$_;w1 z@$|PsVU=dmd$!uVYG0`KLtAEae?Ljk2uG`^n^z{*o*%tF)Q85mN6lAye~k)q9nEV2wx-+)ML{~+HW|cflCp9;t-5|)b@;g5p_?Jx+Ceu*0H9No^*UEzD(V*z}TOmw(aep6TO!n zAB!6=359Ze1sE~~xDINWF#R3z16Vgpp0vk$_E(J-gz_n@mTx}C@(ou!$e7R^V|qVQ zK6~#&slG)CS-3}mSIIS>A0!?ai0*2&Oq~$sfvyj9y)X>bGdwc>KzA-3r2yE9FC2!w zIr(d9>^@^m6Bx1sED(ad7Q4NI*$;DUjN$A#`|KkQ!rUe?eBVY5s`^YBdwkR!u=g8jdw$2wgDo+B zD;Pp9w)7qHkneI$MhAMGwnsul0)qqbY2KNH2+}+>ZX&Fo5O%jip0;dyS^S;3N!Yj?a?6szR^$0@B-WA&FFeg%ywvmQYll93{3t3Le%a7(j;@3mzAEw5yVHe*u#l+hjW$r`T)@pcx|62 zzN6?U1wfoULBKDJictzny~!{ErbC9NtZ^&_D9Ik7=?JT~mC5zE)IvZ7%~%Js_ppzV zcMVgm6a?+DhPhg9X=CWCsA6W*mJ#@0-6Auu6$mv)w*rAItHUzHAF32 z7+cHbeHGj*Dyz(ZP`|rCPHzr_AZcddkQy!dUBpqOK>{b%1lOe~b$p&v#Kmr2F;jyb zr2xp&Ck?y4*ve3ZLAF(!9@A>5sw}1h7>$sbHZ+|@J3}%*mO_2D<7wydHH_7Jrc+g~ z_ohJyX?a^_<@xexOXm(l_Eom^wWz|5jhO6{(O=!P?fdBoLZLj-GE0*!Nale!x3hdiNuOVW|$Q`K9bvnV<$` z2!x;vAL4|e9)gbvXb=cN=w`yH6OJoay`31~kG4;JC(}_n0iOaq0((2V_`y?6;ngk{ zQM^w^T8E|sSZQysH=L_lq4MgRIy5fqM}Asw9vot>uV5&qKJ%+O?Z~w&e{Fg5+xI&2 zOzpMyx!Ld9rk>XMH&)&^+f`y!7;jJht$KIu_uA+AN8e|9&{Ur+UDG-Qivv&=#u+#V z_5}8XunT8qj;`jCfBmE1^~y;JK1u}e1z<-UCw8yx;1?d(snMmOJ=;55T$zsPem>`u zWOwCQ77&!q(5@?Ig@iZTV+>dc46WBNg=xw%q_=IQIoFii_xy@Fq}d+3u0jD}q_Gv7r>PCxbQC>qc{7IHat2-g0fI2nix z5WH}*cg!Y^?YYJWzGA<}oW~Jc!X(of{JbtLhkY$cZgr zj>6vMPO&^nt_m(16u6qN6L(GOrT!o%hc1x=kukO5rerlwZk6MI>&Bp zx2A({WQEQ__!U2+k-?;aFBFd>y3#>lD5@J zD7Le9ww*LW#ZWLC)j2m(#_TWI`Sze*&%ilxUK0(1;An_nE(N{{$P(QAO1XH;R#NNYq3lErS;iK$DK=Sx#`;NNic{I zobKBmT00A~H$N}(S!}wvaHNl`#s*Iq26H?RLR@Gvip1IjyUpoppaz!+9FkE z^baoN?nf8brgUdI_U;|xeHZ-2U-(LX^xylPL#JxpmUN^7VDr5^0W3W9XZx$1-nmNW z10KWt&Q-tAxhM-$aA;5g0I?@{ACLJ!@I##HIe5emQR=5v zWx=>guWN9%zOUT3mFA`&F&uG0Q}Mck8oSl z(IS97J`G$BaNp&{g8BM7{bCUr*f255)J|svO2@iV4znErfuwC&S}IH+X?T|ffrO6W zJz)sZLF9=H?;^+xK0^H{1XBKI5G4H#Nwv5T1xD^7#%EA<)O36mBiXXILecI=2i?E5 zLaw*HElz96GV_>mv&x!U@+cWgQSyF3M37FHCG$RHtq$IYJlsT_Kw6(NE<_ve5Q1mn zg|oeI+Bu%z@pM2Bf1NvA034|kP~eil69RYdNv@LF|B!&sDW~rIu2Z(v;gzd)rYzwh%m*Q~mB z?EF}}_Itkgt<6E}PYeMWqVJ~H!UH+?Eck%;fg%0;07D22!7~hj#Ue1wJ$?wh`ea96 zI>0xahi@5q^gD)*Q~+#5B=&Iu=H7F0cNgbu0#GD@T9X=&bIZJzEOUntGPA8JTg--n z8uIzvn1mwC{rBtqZ5>v)jGbG$--^2Sql3yHhFSMxxc!)rea;;uh*k*+-|X*q&-U2p zduUH2VW2bqiVryNkwt*P_=SC34s7s&VFAMcix5}@&wL2%&I6}9;rNG z9-NQJU@^d+hxq{WA+YCR&j)rr><;PY1A8H`7y=Kj39~NukGBCoyrN0BJ>3cc@NuFK zhASbk2qDc)SG0BfaD`c_Z`cY7E$_WKTo`%OG|+OoVWGeNZH@sIgx7Mb7{InA*uU-b zG}j$e=6dKLZGAm;+>EyESI1%MJj}gE%Z%Mv;x~~L5mIwOe88vZPM-f|h$ev_q6y%K zga#IYZ69y}9$c?j=R3~Be|m^Vy6xyz2!KxjFF4@R&JMfIEkS;CzncBmEctANgV_Dn zL@=lz3zXKj*E%%{p@*pj!G1J`672P(CdkO|R?{lxJ`8j2ckN;8Y|o8tUysl{=sE4| zO!flN5UmOEh7gPiP=4OS!bcNe?n4p;aJm;xPn|Ude)xRM4Y;G|$OXVg91rkufQ1NK zT~|E2mci3s`(c-S1Jpr;Wfia%fgp9I8wh{9ko1n!** zlVS=?fuA@Z#|hjqbSn@5z()m`4+GE5=g|=eOZGREY^?m@jZj!BZ9M+=8dw$-SwLv{ z6iKihtJ3Jzq?m1{-Lj9NZSyKROb5RaW;+bsh+weoIjGGCJ4 z<*s88si1uRn9a5g8Me%7sX_|YbQoh?r%6MMhyF$wf8UNfwhY%k*Ih5IVzTzw%b|lb z??GC4)&0jb^Fi&{uU&_^hvC^wn)+);GuyAWl;@C9L5ShN3K2wqKnM{X%mhwN#F_#R z0l#pkm;<*;0DJ`4a=`ODJM2QGom&Q0vI#d;nSEBhm6RN$ws_S!T9d$-0G6TKJOi=U z7*cKja+vZk3^!KaVKnf5_1#F@+G96^ZlwNIg7Cn5S?!-LDl;O7YIXR4wG!fJ0Z+^m zSopvq34{3nr(6{k05}8u^m+L9!@Pszq+2BbE|Bs8c0yolGQqXpeWex9+aiM&IfUl= zpye!7Um-LkirLV4001BWNklp=bzJW~ z4%7CQmcqs(KQT89rjYsv0wAO;Pjjw{GTUE@9xRe?;B?GXw{2V_`UGz4=)f%z04X8p zHw0J=1JCa5;nZ6mN&?T4?W`i$ZjXfP+UP;vv_Y&}?g+?J;{_Ss@&5L^EA4 z9kn3YuTDMJ!t5Kp&)7W=5*9Bjb=p)|&2}D2yvp?#D#?daI#xc8a?nM z=c6Dv^KzPfRCKEl0KkWI;|1p!G#m&u0vJOBBe?*1ch%imZ~d5kpMKI@H)bEUh`Wch>cCJ znp=zjSjzi%t{{V!@om^}BpM*iU)!Fe(%3gb`!V#*sORO>c|G@1TE+A$-+7>d_qKu% zSW*JfM-U79^c#XMX&c85cn`h6dN*n!z6<#E^YESnAM_T|EfWAKAK*6t_Cnyrt|Ki1 z9?3=q>~=b5&4o%pj3wTvBd|JT9DeC1xi>t*S60dHuo4CcW@&#*70u!bKMNY z5V$^*;2>nsqJzV>VeI;rdR9aLjP} z__6abWO(d!D-i&|2ZWeebzvAFB?T#Et=%&8K5=#Qnz3zrED4n?2u7G%nzEzyj-Y{k z(|%i%=8)!r-9CsRZUwS9jBvOfVRBG=ujia)%J!UaIG;goSD;#HTp1rl1!+694`av^ z1614-hGIs9Vy*v0r0E9P6u3EEZC#@I7XvZ@6-r|w!By^Y!ZwVx(A(i zfTq(~A&?+{MGa!8+GOfq5)@Sx30aJUIMMbrZ96Q3tfK4H==*8Q&d1S&$F|_;trh^E0zM|d)?&exzOTc9 z2I^O|%1PLg3H`OUxHJMHf5aB%L&e;coqqr#sG8FLM$p26&vS${#t>sn_HydI-fIpc zu#{fDQB~i6tlrGbrr?2ns;4eM~@)&&N z@iZmrt)N?t03c4Gv=HFA5SWXU{QoB1w}ofrM5xQOLcuU&NM=B21w>PRNoZK}L7H5F zF_XY-wVQ6VaaSEfZYRee4u7d3ei;=H7HV4gs(UY&zh@-Cef2Zn+UHgEuf)6rR(35CiS4 zZC*L|6fsZ>4^f71%I7%?Q<)_M(U=_jk*(KMvM=miwZCfndg1g@G3m>#vlVdd?|RXN zmT#i~wvI7{v&#G!``$8gKA3$6oalsEA15kZ(e`%}9faRHe){IpEf)YA5edCdh@%6a z8iq1WnEnz|Wa-<6*|bb+?_2n;*ISdqo-?xxFXaZnl0aGV8|2MpAHtGPVdQT{6Y+tT zgxpcm^$3cWBOu1ETUFPM-1|litHV4~D`>_v|9Xhc3aYaLh6eF z);i(7nQ(T^Ax>6>3%?)u@$*MGd-rh(fKA{dY6e`k(E!8PWA>RO;ULC$U>SI&Mz+x3 z#q|X$2cn{ZRKCp<2#qkv$5NRkw6TIl&#dqP+@<~Ldd(eH92=un)3?H+H9^D3HLY6- z0#3lWs2H5Uy)(z7r#ntfrCHA)({}*>_>j%MZn~vW0HqWSxL@EK79lX3On8-ZF{5hC zDQE2Pd^|C*wdqG^0c!1b(~bjKPO}mdD$!qc-9e0dJ&b)o*|wAEF-DFbL^s1mZ#Czt zHXMa$yHVs|uM<`ajQva%ThFR%19ew)A~+E`5xO*TuyaD^gcE(7X?QjhcIKYBU-C1& z^D%h(arm7Zc;tQQSOfsTV{j4p?g0J5IbNGkz^XC()`@4CerYigbhi<|mbsb~-X)~b zqL73(T3Ol`l$7KSr z5!YA$RR_GZx5o?4MQPMBlcBNB+>RFrx@|SL6c4@%5V6ePq7LKrFE^L?vRYFkmCqfi zX}k3Y*tU;%nwzgH$24VYkK1Eoaqj)``T4-4O0x}LWcSe*l~s{EMmqP_oq z$Or9Ksf2TJuu$I#eHR(O7l(6#xM+5sIN^Bv8`t>iFF(b@_xASwZw0>oP!D?@bZi13 z(N7EDz2|fDIic%n+kTA3JmwbSk2&?m(11A~+VaNMS0`dzo3N{vG|SiJY>(ws!!IuW`q&`Dt03H?OqCO{|P zgtHG#_{x9d9^Um;XP8a0Gx^J3)`N}Ek**DR2>M0h5aEZO+1cURnbWKmmMDYu_1OQFR7&ecka9wt5YieWL824}z(eTl0w!^mm>ABf?;8YylRP_d z$^6h8ha@9{X;5k7k_H)tIY&d*7CuVaul`l%_SLM{QO4ejRF?bl+ zIx2cO8rU-3VFk#Io?sy3`EDEcWI*BxGXkK90Z{c9Zx=Sg`FX&v+m*{UdeUQaU%eJ_fNR@zU`mi z|DA3DpWQplJ!@YEL3Mg!>|p+e$fS`R0aucRL^2*wU%jsN8q!2>3uSr&UJ?_#K#(D> z6dOF=4Uy@^Gq^wq1Hr}R#Dj#m9X!DWd`QcT6S6=EN%JGb@;aA6YIQ^;MF@<|cdQ6U z!r0kDR-3iQ^|EN1sZ+cM-{;6M8Dc z20YQh<_YGnXVCtU$}iIK!szk%VCo#wy$0I`W2Fip9y*c z(#K2PO`-q@!CKBq7`U=um|n8OCo+3tgb+VwWZVEg;1gr}q~X0pVGtw=2rrTO{gAYM z@C*`#gLW04gi8>QC&qB%Y_sXkN#I1eploDE1upBc(DK5e^kFRyO8t`e!pb`?@9!si z4nhI7FmUF$@IlGJ#R?o{^r_#90la7nA{ zz9!^Kbu3<6L`rF+&-K(oCl3ED!o9R1*4roeKfy5pW;mt@GaPF;))3YZ)^YT}HRh=e z9^!0TzqjI{Zv1f?|1{ z0^5o0+(q^O%ViS2F~^rnE+5tF0(IS5ugg(F)()X|`w79C~(h8~0TXAUL zSp5daj}_AXSI$MpV^mQcF8w6^oDl|&o{lLU6FS!DnX^bZB+~~r*xceK(`_LDHrV_u z@QZ>lU(9)aaV0Teq7YD5sCEcxevtSim~EgBFacvtByWFWNJ%kRhvai2f^>rGbe|N$ z5u_tCd9+NTaERf@klYp#dXz3vm^@o7XnUfQs3Z#&Q^rz&hRY+Yzr~1E3$0l?M>^r8o#Pp6?IyOrfVuu}zqb?GM(cg5sEd)TKABV_j&+lAj zPkh4$f~Mi-rJf-74v~-+`A7#sJQf8L>;asLXMS3No`h^Vewj&Xsgz2Z)Q7 zo*2Pl(S#%k;6S4pMS~d)lzY`Uq|KdnETi#2S_PA9{jX&0<#D}UGqqnTS8uaaw{_yx z!l|@s8NswdVAYe^`rG4e`DHXzx7sp!Il3%>ZAm?wFk*^PMf<-u2w;--^*2dEV4Af5 zUef=D-nYT#g^@>l*>pPzfL{eZA_&{N+dS*Hh%9D4g-HIIHtY^$PRgc%m`{>Lbb|R= zOBco!4Z|d@UXDi-Adf0k6TzjB4P}mjXd0weh#jM#zt(IiP0yK%`DhI(4?|-Bwf*0+ zy=9D6ll!Eh3!WKmi)CK|?>uV$|CW8=@g>WW&-C~Fr1q*&6nW&ahRV&FOc zD@a4K0B}fR{3ryp$MhNc7wtczV@8}CW1HRfyZ_`q&3IXK+X#RSHa!Ui2=LtYi!Ai@ z=Ycq-dAk*w7%|7>DXqE zIfLyX|BR>{kA!X;0g&kDfG;>4*LJpfj;nOZno{VWUvQ9Y0%U$r)4({*L>VzL-XueI zhjT8Q0Fm(xq!(v|L1OGqO#sO#!8!#MNw{Q2;9?!+TUztL?JoqRbftqdQLAO^V`Db@ za;Mk$csaMs{L0KF4nB?qY^>bgyA}k?EH@6*SDm%bu62#it~6F_?W9~5j`r=@cd2iv zs29m*f<*v=2KS=FuTKJ?&rUyKnzq&UkDmXXwqN|Cq#TcgZYu$>!RAHapTxbuv)3XD zC@&;tIl_ohX5 zyB12z27bGW4I( zvz=^z(P zYJJzhcynAKe=b*0ggA%GW&(A6sm>B5Ae#rt5m7}umXm)DAgMbr)pjceBH19^IP+`v zTQFL@X6hDE6r@m>UcR>A6N^-825>cvI=N695}*eiHb307BrI?dS0hBxTkK zabQk#_BYZv*u5f^i-s;*A0iUSA-K%A<>yrMr#yhn>@MYNtFXvIqN@Z+aRQDw1#=52 z!oj?Uy6YC*Z=bkko-lf@wa2wgoxxVl?+@?QIp|Fpd!*E98Oc}ovcjP}ZOw3PbYQgs zuo~(w3y%FnW6SXN9V!{avO#2VOPzu)!~PiGSLUB)ZSN}PU#I69J1kgOCAY~DYk#;6 z1wf+z5%3Pj&e0Su>PR!T=i{ z?9{%OBnXmUz}&}WXCk2cB2m+;_O`-6Fawrq#8WzBu{q;zx(@q`9osthYNjluirrrH zw{`fnj9&zaU-A#sPQcKZ5l{;js&o4@XDc8u*Ok(>2~?XG<;}G3(+a?GlfmW?w1U|f zf4CItb4mM88rZL1e?lLio}%3 z&z|p5Bb{=#rsXeCz2K2&u8~k3*=Uhc`CGT8BuuN&R*|nUer5hXGrKUQXPU!(J?rLo zf}Trkv(26r_`k8i=J$@iyqiq7D*^!cM-ZjzmF+E_9j-ar%l7h;t{#vedG%*@A zYUpIO*%V*Z_)s)>&J}P-*Vy+`9D>=Ymrw#=W*!n!Dp(WmkB-91-(cT>Se>5_HcZnv z&ZGv^HM5UfQ#wCTaMxD@l=?W?v10EYQp4*S*czh^D|joUHhcZ=;-`~M)fh;CZ}u)*dp0Urb) z1TI{=$l!u81Ii1NR7O`|QD)EVZ!~)Q(MWK;mnhe*b5Bu)lfu}pb16mGIQU$e)=3KF zuS@~M+@h#NO#?JIc+ntUWe{6lz3K3kmWa zg4wETFEzBsXzo+W(p;x|(v+*)I%XnieQh2?>=nWE6!Mlby8csp-zDf@Z2#KhU;oqx z;JC!K3atS@pZfkSq1#pfB>IOCQNY&rRi0g3Hokz6C*`O3sjzlQu?0xKc+b+G@ zj(5~DWipU9(60Nn5GY?nGy6)IPY3x(vhSk+Sj$>J{_OrXbFQ*$wf_$AcesUgy998Z^Q{e|cDOeU5A`hd;!gMOIk*6{RzvgUz-vwv)A{unTE^Pc*>j# zzF;JCUhB{WIa*<2O~sIefXkkKNt!>}{aqE`S8xAXV)j{z`C9>SIXV7}_J0ESq0yIo zgmhaAfJ8qBd>G=(zHsFt+hMmfJb>WKq@4C6hV-AB0%~)k0MJVG1o;tq$SK1#jGd7{ zb_S||=nT_KGoVNvfiCAAWbb~u#-{#BZe0!gZRf5Y(VUChAv1n~-uX;rqnCX7x~?(j zon@ZoVaF|uH*HzLylsv^o1s@TY%2yz{q5KVz28{&Vtv07(rjDm%^hNk#3&D!nco=` zKyCkN^7c9!05T6&xd;V~Y00eFuf%!fI??|5K( zI`X?_)@3YjoM{vfd;D_7^=CYUHaej8c|hW{VfxvvZ$ZfRb_5Z{Vh5`Ojpx`dHc~n1 z()G${2h=ZpwYhVPJy;cM+*Z2lPbn{a_EDej-u*spA``8PNQ zx)Trp8*KhOX+)I6@!XZ?d2!e&VZng${%5l~e!!&t?J=qTk7T#COZJqIT@(%_t=E}Q zVDSey<2!I!)8{ZE#lFudAv*+}`U8uh?@H_9e5j>EM_DJ8a0>dJT@;~_*TG6K# zzD@R#G}DjE;XOO1e`Y-W_IH8_J1lsSYnJ(Ufd7(XqB}wWB>EwUoozA9`Qo)_(|r8V z?hh#pSb9dv1Wfz!T*$v1Dh$Q(ruFA@b}`Uw0@QYX9yFwp126-MN`xW*DE57H{JAU; zvJlXHt2GJJ46M`1%~)kp!BcIF?^@&ydz!-_#cA!_`zZJUB&^isOk=9cMO zEnk=??Vv+0!)(szohlry#6l3|H%09_*ter%QhFdl7{{O@NwX~9_PX?$3%A$0)QAJ z-2(_A@P#YSuovRYzIkv^(*D^EZXyI#FHPt`O@lm_AX=_;)ZXR`-Y%KONSag>nvw?jf(jMOys^d3``FW9!NK%_0trqk`4oG+z{m@;NoRlAjNw)Wzu(RRgJN{zPu z$iz}TS1TxDl2fU(b)ZUapH$l#_g61}M;X#POANoBLw*z1)Baj={C$Q?ykv&91OLkg zn}2`lRo-H{(+~i_50jQiatKeq^bD7VZCqB1Mf>NZpM(NL&tbNGsGNg}2y{Qs`xeY> zLOE|Bk{~(r4>dK^UyvMm#hGZ>AUP3L*c69i^br(IuQyVdU|Csmr!Pzp{|;cZY3*Dq z!*|4bYv}gosEnVu-L}QyaWHS-1o-PPLM>SeaZnbvZo>=Elfd8NHlRBS0RTMCg%=*J#7vQ|ipIxTk3NQ3(`EXfm~Eu2_Xh-T^`)U!^Q(?2N*){P(`~KI z>cnD^7}k<_P34FaG8?z>emsuf?psk(KS~YT57Pc&MVT4}gry^OJ(aLaU$aIDpdOjA z_ANX1?4YB9j%uxM+g7ss1kLd;^Z094pHAnkgLoAmQn zH`x5p(yKfMx)Tuqz<*DiFoBMaOIw$C>e};hk`9Pb0k2vG*;k;xMFS^Nna^{%9qa!y8*KiQ(O!KFbjKk8fXBJ8_ZW{nBk-OM zk0Wqxag7Jo?_s7wfMA0FIJ0IzW?1Z8dr2qgtV4QST?&-r4(O7Q$!is$f+b~;r_f}~ zQpA`b>AW|7ab1F31ys71U1c(anC+;^NFnID2_YeaI54V41j?L+-E2&})|JJWXxWSf z00116Nkl$3R4hD|j zvkbtB-hExePhr0>L(CN3E^GV9?B#cgj+5!{4tso(XNgPLf+JjTgun2MJoCcni#-Nf zMs#-&o$vqnd#}-ds{~>21NYx^ALs6ULrk3O1nD|W=#RfnCkG+V?5jO4v`ICJ(lz-e zL2dmk4YO}{V<4Bp3Ud|ZLp`+;Eof{&}y4nE%}*B3%uxKwi; zi1!^rVR%o#2fMOu-1k{yrsS9qDto$y?p7?cbKZ>$f_Sd{Z@1dN0nMVbCQsZ_7;5L) z*K3<>h>V~V)!FuIEA^cW=J{HGh#lk;vXGA&qfdCC4DF5c`b{Ky{nzN2O3##@HL==% z!c1bq&zd+sws@N7*rF>y`?~>R8=d68clfOzUHLMPf$nGl@aMku{ zGJVL*pMN3X2XlV#rTmc2r?Nv(VPOSIU`Xg93I(49MBE<;VJPhhLq4a_Kad0t07GV; ztSLj>u2I2qG+)`bdS#ihjelQi5l~%`d@GsJOA2H%p^D$eMhqnTWI_{gDS|P7C&TIi zpO<^r_mKsAhIzW3vOT*#K7ZdMT@S8=@9`(OUGKfP~C zp0DIfp{PyRc;2Yog4kiL& z2)F<)sIx7^5S?Lo6%J)CfmF_D#Sn@a5RyIbh|KR2b4ofcsT^rr@;Q%qvz>edJ`DKa zQ%Evi8|xhMeh3~(CPefVL?(xF-uVSEq)5e(nK}fIPM+d2v!*(N;HpuSb~WZQ5H`P; z^k4Ls6rX#}9yBS{DlvjGxwFt87?OS$EniTBIQ42KB# zk$#EIjlafiN_V~h0J!k@(>(GRz}LqE!gE)z@WAO)oSmLzP*1(uo~gfT@?K3#y`9J` zQk7R`RcKxO1Q@0@HB^jmO^J}8xivpRbG~S`vYj-2fb8WD@p!R`L&GFK*}BFDuEVKG zeFoEg zz_8vgl`pTyYHDRxW!O4jG4G2>YYGEFl0B~i zFXuQY;z=0*qW4M9We13LQW(AOq3e?7pTcAkwf<}k=_k>_mzjS(+Wu<)_a~w-=q6nJ z-X`?QKmY(29``)**vEix1x_H2?VVkAWWnq2c~HA01^!bZ zfq2Z=x?;S|!7}bDs9!XH5h7#IKN!cJ7!yIw2xAf?NS|$aWACfx45{17#J zg7|6@xN^QEfj~%;yXNq37wvrM64dW{=qFhSNX7KCto>y=i&}p&i<*D7Mt9;Qmp=O$ zp8eDpqcDl|D{OB3)zuyL_Mlge006k~__I9n*o(k71K=DlY+Ye(ZNeib&Zc;}WKCOU z2X5@uM9UDqJ{FH#h77dA!7_dwMzm&w`T49vlWnhnS3_9Dh(p$PN!qwnPQzUKIQCi7 zEWsf&bt+`EcwRcqW>HC(1O&AfjW3TJR&iBDX)~#RML3eueZ=??oDssd-4*l4@1&@w z_&HQqgEt=j@yzzRzcH*hlFAhJ$^hrYp@9{zN+--e6?|ZL6KZXAi z)P(?{ECwct!GmRpv@Mp2a~Mq5IZ!*l`^_T28ssKOvsk`Et9Ls zkj)Yo4`?-NZe-7Z1r8G5rMR->nzm0ywSI#8y4@$I-*g&n{(fp~{b^+QiQ4}&n6Bfd zC*t|pI)d=jZ-0#KE8Fp1MEaX-Zv4V^^x9*iJ3b7!g1#3x2Ydx0?CmZ1%_o1KZ+P=p zaI&8;5YuSAk6I=EjTc5oUxDM+M9}lCFtEpKq>waucJzVwLdhurQeZ6F@li`-1V?0W z@PiIV_Q~c=x>4eW+WXnVO+qDUet{$w5EXzK?068JqN2PAJskpwbGgm=xc(oE8I_$4 z_9aODuJSw6Muqeaf;p{&xy-R_(!~0M#1LYhn=v~V)AMKKkr04Hfe=)nb$t{N$pIKm zfk`q0rYYISqJd-^GU^037Gx*d^#ugWOQFAhhG2#SCR!7~iS<}YS} z&FE9);LBj45TY~8ddzd@PvI_?GTgJ>4!ABtV`U8WK6Wn7Y}|E7S2GGuaH=&E(}?a1 zi0g~CwP}|cO>hP!R2f-`{WB_222b0z-5Q-pCPU?{gaY+5L%ZVPcgeG#;`weeMJAJ| z{gbWFB*yjKY~6VM*CXRk*KxCx$mB#40yFycQ(XDNXL;)5PsDc=n{g3%4;LPP?#4Us zttC0Q$Q?}Q&i@C%Pv(6;@W)^GM&9}0>sfeTnX<8877bP$gvyWrCFEBecWTqmGn3lv zznBd; zkP$?Z?SHHB`y?lM=J!hDK74d3bCm5 zMbS^!bj z`1wEB-1xQw`{Qj!uY3UjaPIui0)GYo@0m>}{K+@Horl-XvIv8T!AC00zuXbWJ^J&C zxpffF=;%IQn0@d`XQ!P1hyaR)kA8sxQmU}mfj=e!5QG@rNJ&1ZR&Tb0GH_;iwT+2_ zF>B6bPm{_Uqd$A?vr<-PWb#jV#aHHl_U_u<1%>&c zBoMXPeNp3EXP{L6fDnj-evG|hC@DZ1!w?@h=(#i(0x9AFAZju| zEN7lOdl%I)>CB=X&Sj@(WNM96bXoI9t)EarH%UUE%l-hm2`(|bMh9HCmh%DVCpaS@ zy4e~RKk>U<{M3`sXXf|7U%3;RAHGx&0KmEPZv);BJPLpxc<`RHeEsX*!9+Sd17&ue zI?1Q}9rp#a2%u@$eRHU^h$JUh@McRk?m`oy(v86rcUj zhw)U9@xNko<8Qs(?s;7Fr6T|U&Yk}n;Qs>70x&Fi-2)HtwXbl*BbuYuwF>e z*QX)Cut*HP4E1Zr-;jp?2E1RG`2rG?Gi2vq5dd*wj}XdKnus#L3H^1FvfWe=Bq7il zt*E*1qPDTC7e8@23|EtSAV`Vf+xO9gK#Z+F6y{EopeQn67}7ikNhpLN3xS}5Lj4Wu zU`_XqfG0&AvT%#f6jDUPiOUYYCWCWPJc7NhgH4f&OLeeKiMwqJTVyz>ow$NZMX)eogop;=~{-WC#Rj5`e_#-29x? zXENS2?KRrClAK?iiGz1(%)1JO+H;Q9x;9C2>^g|=ifsN4@Mt|_q_d)M|tN1 zZ_H4-?ncy+Zz!Ef)|%TAG|L z!eNcuYb-oM{ys8`!eDg(b{!%yFF+&-1sDAQQ3_6?hP7_N#F(0t6q69=+4E0|cAzL= zSVXPwhh!QI(KN7TKo$lK{3qWug)K>puR@?8nfU8*8rn;-f60!(Y0O=4iVn&MKv9!H z1xeQ-;&8Jy7FRCunP2{8uD)>D=J{U&zLCw1V_VYeX3>|X00205{yTsl1A2v_MVVD`aTN+6Xy?sAZd)h3uR#s z2hv4&@0}|Uzv~F86UUKluEe>W(P|nCcM_SzO%tT}1Ap^(CJC!27v;;RT!Nw*dZqHaC9mCilo=p)Xwl0C4X7w*x;8OjA$h%N~3c z@4W8~5!osn%|3u42qM!j(sqINWq(N8J`LCPLly`Y>Z@=Vf-k5+%q+gj`~tzHa9!tO z6rk&nzGS~C0uUYG(sjkD)pgLX<&kgFC&ozRJvp3KO$sV5rP8NWk0)`iyf8GjJ}Kmv zV0}aZiU>Rmp5S-0Lr_ful7P&PL-hqfaX99&214;&r02#N%|0Wx3lvz zn>>14aFZ#+)+IjsE5FQ@3(wndAHaXc=Egs`$vyGd=u2Aw0GvDjXMmpoP66OOZ@m8@ zzViMzLXbRosLlwC%wKW=>Li~$nWrWNrRlqdj0TduAB;I*Cb0B)a52qC$KEUR2PgP0 z#d<`z(W9pfk*FofUmsoP4v<+gdsD2?fmmbFenPBz5kif zH3Hy0o<(H%L6^T!MBtb0{Vu|OwR?k;GK95H!&&>t>>)9I9L2T{IOcoX>|DOW)t9ca z_tF)%cNPqb1z|BjU=NWe5%~lnp9MY#Jd3bn-p(mPcm#MOKD-t0&(XeD3Bw}YGNlkFOC&Fb<8K~S7d$SyD*%+v zo&O4=5O_NP-t)ledwAD&)A{JRXp+i}AB>64s#^wpew&1+eI=waMs zf*%ILVxAI#hQjDM6lhEU%>q=xP~{zHmX>5QMV*pxY^64jd@`Jy|?zKJZ@B{d}Y;Jtt4fU(robCz$OXto%L^KEf6aaqU^x6r&;=b4N zz~mkl-siBN<^pI~P_=)|=MTlXXB>f%`6J^O$6p|%wFsi-_h}*vQb>2fh~g%MAXT8HO`5 z={R-o8BV|cb)0>}o0;8nHlm*SULG15R2T$bd;-BIM~BS@gv|WO6v)hL9e^6z6iN0! zfQb&Evkyzf^Z>5!AuM?AV;|+|kN!@~T`F;YfWN`!#^1Xs@9Q?Cy8@u4*r|U2_?V%+rAvJA!@t4vfAE=@G*qTEy9WFxY;OFoNBZ85 zneGaJRdnwBw*dbTcvL&&11HY#wv!KYN@j5+UrN(0$w4I=Fl4P?`~gE4Vi=If^wIVo z@(i{iP0Shkn6Veqcy^ieFrB1v>{Av2u3p_`>(W)OZ0*L-T4V$dd<^*CfPc#7##6`e z-lo8}0DpxLzLv!T={rt8cpqoq{1(oy> zUk&^S@aF&so@w9n`V;r_n*JVo9P>QP*JsEdQs^&F=z+(FMS}gw50Gtslh*4)*e^3cG=roP&zu#64O$D68P|Kk(zq$yd#8E-2 zW52}^Nrwp9xXFNJP%LDEtE-g-~ z&Oe`h1B)2)^FF5jCXJ73euf13qX58>Y<-7I;k!*m9mElt@4<%$SS)a}o_ijCkTY+5Gp8SYl*#EcATFT-H38D~%~!`{5L^)CYd1Mv5c z+)r{F(p>>?y>#yU1HktH|1t28B7)v^+~X#kX38mqJ_KCwae43@{)+;Dv~YFkz`MZ0 zITo(tTIkpd!qq_-)Fc)>(I$N#aU|nM*xcAVuE)PA6dkQ!4g6W)oAKc-3=42DU0>(a z{byNw)oVF*-#ttpc$j{+mX_-3%aGtic9N1X1j1rq@9GtHo_&fd7cQ{%)^T6a~RI0e=DbI&@5dfJ0bw!n!zQhzovBo#xJac75dR z&QYN zs|dV<5Z*%YuOoyhgP-O(4KpS4C`i3Vfs;MrsJ%}Co524IeDF(I+mF#*0dO zTZkR_&AL%aT6tfOroqms|zpo*17C1v3 zzu{vHFu&UcQK0@l@M+)z@Z>8NLEWXhbeHbZUAjwm=`P)+yL6ZC(&6d<2hyBclVsb> Q +
diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 3413ba1..4163265 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -1,32 +1,59 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Email where -import Network.Mail.SMTP hiding (simpleMail) -import Network.Mail.Mime +import Network.Mail.Mime +import Network.Mail.SMTP hiding (simpleMail) -import Conf (apikey) -import Data.Text -import Data.String.Here +import ApiBase +import Conf (apikey) +import Control.Lens +import Data.ByteString hiding (putStrLn) +import Data.Monoid +import Data.String.Here +import qualified Data.Text as T +import DataTypes -sendTenantActivation :: Text -> Text -> IO () -sendTenantActivation to_addr activation_link = do - let from = Address { addressName = Just "Sandeep.C.R", addressEmail = "sandeepcr2@gmail.com"} - let to = Address { addressName = Just to_addr, addressEmail = "saurabh@vacationlabs.com"} - mail <- makeMail from to - --mail_with_attachment <- addAttachment "Test attache" "tips.txt" mail - sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail - return () +sendgridMail :: Mail -> IO () +sendgridMail mail = sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail + +setCid :: T.Text -> T.Text -> Mail -> Mail +setCid filename cid mail@Mail {mailParts = alternatives} = mail { mailParts = (setCidInAlternative filename cid) <$> alternatives} + where + setCidInAlternative :: T.Text -> T.Text -> Alternatives -> Alternatives + setCidInAlternative fp cid parts = (setCidForPart filename cid) <$> parts + setCidForPart :: T.Text -> T.Text -> Part -> Part + setCidForPart filename cid p@Part{partFilename = Just fn, partHeaders = ph} = + if fn == filename then p{partHeaders = (makeContentIdHeader cid):ph} else p + setCidForPart filename cid p = p + makeContentIdHeader :: T.Text -> (ByteString, T.Text) + makeContentIdHeader cid = ("Content-ID", T.concat ["<", cid, ">"]) + +addLogo :: Mail -> IO Mail +addLogo mail = do + mail_with_attachment <- addAttachment "image/png" "apple.png" mail + return $ setCid "apple.png" "logocid" mail_with_attachment + +sendTenantActivationMail :: Auditable Tenant -> IO () +sendTenantActivationMail newTenant = do + makeMail from to activation_link >>= addLogo >>= sendgridMail where - makeMail :: Address -> Address -> IO Mail - makeMail from to = simpleMail to from subject text html [] - subject = "Registration Email from abc.com" - text = [iTrim| -Hi, - Thank you for your registration. You can login -at www.abc.com using your username and password. -Hope to see you soon. -Regards, -abc.com|] - html = [template|email-templates/tenant-activation.tpl|] + activation_link = "Click here" + from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} + to = Address { addressName = Just $ T.concat [tenant_fname, " ", tenant_lname], addressEmail = tenant_email} + tenant_fname = (newTenant ^. firstname ) + tenant_lname = (newTenant ^. lastname ) + tenant_email = (newTenant ^. email ) + makeMail :: Address -> Address -> T.Text -> IO Mail + makeMail from to activation_link = simpleMail to from subject text html [] + where + subject = "Registration Email from abc.com" + text = [iTrim| + Hi, + Thank you for your registration. You can login + at www.abc.com using your username and password. + Hope to see you soon. + Regards, + abc.com|] + html = [template|email-templates/tenant-activation.tpl|] From 95f65e23213feffa92bdc4efe2e5f6402cbf242b Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 7 Dec 2016 16:06:35 +0000 Subject: [PATCH 51/69] Fix double quoting of links and add hardcoded key --- SpockOpaleye/src/Email.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 4163265..44ebfa2 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -16,7 +16,10 @@ import qualified Data.Text as T import DataTypes sendgridMail :: Mail -> IO () -sendgridMail mail = sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail +sendgridMail mail = do + rb <- renderMail' mail + putStrLn $ show rb + sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail setCid :: T.Text -> T.Text -> Mail -> Mail setCid filename cid mail@Mail {mailParts = alternatives} = mail { mailParts = (setCidInAlternative filename cid) <$> alternatives} @@ -39,7 +42,11 @@ sendTenantActivationMail :: Auditable Tenant -> IO () sendTenantActivationMail newTenant = do makeMail from to activation_link >>= addLogo >>= sendgridMail where - activation_link = "Click here" + -- @TODO Make key random + key :: T.Text + key = "cmFuZG9tdyBlaXJqd28gZWlyandvZWlyaiB3b2VyaWpvd2Vpcmogb3F3ZWlyb3F3ZWl1aHIgb3dxZXVoaXJ3b2Vpcmggb3dldWZob2kgcmV1d2ZpcmVxdWZoaXFld3VyaG9wIHF3dWh3aQ==" + activation_link :: T.Text + activation_link = T.Concat ["link-url/", key] from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} to = Address { addressName = Just $ T.concat [tenant_fname, " ", tenant_lname], addressEmail = tenant_email} tenant_fname = (newTenant ^. firstname ) From 27cf3b3c419da0964706cce748b8973a4c216254 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 7 Dec 2016 17:19:38 +0000 Subject: [PATCH 52/69] Fix double quote issue with quasiquoter and add a hardcoded key to the link --- SpockOpaleye/src/Email.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 44ebfa2..02f3e28 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -13,12 +13,11 @@ import Data.ByteString hiding (putStrLn) import Data.Monoid import Data.String.Here import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import DataTypes sendgridMail :: Mail -> IO () sendgridMail mail = do - rb <- renderMail' mail - putStrLn $ show rb sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail setCid :: T.Text -> T.Text -> Mail -> Mail @@ -46,14 +45,14 @@ sendTenantActivationMail newTenant = do key :: T.Text key = "cmFuZG9tdyBlaXJqd28gZWlyandvZWlyaiB3b2VyaWpvd2Vpcmogb3F3ZWlyb3F3ZWl1aHIgb3dxZXVoaXJ3b2Vpcmggb3dldWZob2kgcmV1d2ZpcmVxdWZoaXFld3VyaG9wIHF3dWh3aQ==" activation_link :: T.Text - activation_link = T.Concat ["link-url/", key] + activation_link = T.concat ["link-url/", key] from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} to = Address { addressName = Just $ T.concat [tenant_fname, " ", tenant_lname], addressEmail = tenant_email} tenant_fname = (newTenant ^. firstname ) tenant_lname = (newTenant ^. lastname ) tenant_email = (newTenant ^. email ) makeMail :: Address -> Address -> T.Text -> IO Mail - makeMail from to activation_link = simpleMail to from subject text html [] + makeMail from to activation_link = simpleMail to from subject text (LT.fromStrict html) [] where subject = "Registration Email from abc.com" text = [iTrim| @@ -63,4 +62,5 @@ sendTenantActivationMail newTenant = do Hope to see you soon. Regards, abc.com|] + html :: T.Text html = [template|email-templates/tenant-activation.tpl|] From 480119f28e86fd799cee1bfc659e4cede1223257 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 7 Dec 2016 18:04:34 +0000 Subject: [PATCH 53/69] Send mail from another thread and code refactor --- SpockOpaleye/app/Main.hs | 30 +++++++++++++++++------------- SpockOpaleye/src/Email.hs | 17 ++++++++++------- 2 files changed, 27 insertions(+), 20 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 0a22d62..c1a73d9 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -16,10 +16,10 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer +import CryptoDef import qualified Data.Text as T import Data.Time import Prelude hiding (id) -import CryptoDef data MySession = EmptySession @@ -40,7 +40,6 @@ main = do runAppM :: AppM a -> Connection -> IO a runAppM x conn = do - putStrLn "request" user <- getTestUser (item, lg) <- runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) putStrLn lg @@ -75,14 +74,19 @@ app = do tenants <- runQuery $ runAppM $ readTenants json tenants post ("tenants/new") $ - do maybeTenantIncoming <- jsonBody - case maybeTenantIncoming of - Just incomingTenant -> do - result <- runQuery $ runAppM $ validateIncomingTenant incomingTenant - case result of - Valid -> do - newTenant <- runQuery $ runAppM $ createTenant incomingTenant - liftIO $ sendTenantActivationMail newTenant - json newTenant - Invalid err -> json $ T.pack ("Validation fail with " <> err) - Nothing -> json $ T.pack "Unrecognized input" + do + maybeTenantIncoming <- jsonBody + either_newtenant <- runQuery $ runAppM $ do + case maybeTenantIncoming of + Just incomingTenant -> do + result <- validateIncomingTenant incomingTenant + case result of + Valid -> do + newTenant <- createTenant incomingTenant + liftIO $ sendTenantActivationMail newTenant + return $ Right newTenant + Invalid err -> return $ Left $ T.pack ("Validation fail with " <> err) + Nothing -> return $ Left $ T.pack "Unrecognized input" + case either_newtenant of + Right new_tenant -> json new_tenant + Left message -> json message diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 02f3e28..d0b9c4d 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -4,21 +4,24 @@ module Email where import Network.Mail.Mime -import Network.Mail.SMTP hiding (simpleMail) +import Network.Mail.SMTP hiding (simpleMail) import ApiBase -import Conf (apikey) +import Conf (apikey) +import Control.Concurrent import Control.Lens -import Data.ByteString hiding (putStrLn) +import Data.ByteString hiding (putStrLn) import Data.Monoid +import Data.String import Data.String.Here -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import DataTypes sendgridMail :: Mail -> IO () sendgridMail mail = do - sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail + threadId <- forkIO $ sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail + putStrLn $ show $ T.concat ["Sending main from thread ", fromString $ show threadId] setCid :: T.Text -> T.Text -> Mail -> Mail setCid filename cid mail@Mail {mailParts = alternatives} = mail { mailParts = (setCidInAlternative filename cid) <$> alternatives} @@ -45,7 +48,7 @@ sendTenantActivationMail newTenant = do key :: T.Text key = "cmFuZG9tdyBlaXJqd28gZWlyandvZWlyaiB3b2VyaWpvd2Vpcmogb3F3ZWlyb3F3ZWl1aHIgb3dxZXVoaXJ3b2Vpcmggb3dldWZob2kgcmV1d2ZpcmVxdWZoaXFld3VyaG9wIHF3dWh3aQ==" activation_link :: T.Text - activation_link = T.concat ["link-url/", key] + activation_link = T.concat ["http://haskellwebapps.vacationlabs.com/activateTenantKey/", key] from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} to = Address { addressName = Just $ T.concat [tenant_fname, " ", tenant_lname], addressEmail = tenant_email} tenant_fname = (newTenant ^. firstname ) From 741ff7d95993e61e36ceded406dae235422e50a5 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 8 Dec 2016 05:42:41 +0000 Subject: [PATCH 54/69] Add user services --- SpockOpaleye/SpockOpaleye.cabal | 1 + SpockOpaleye/app/Main.hs | 10 ++-------- SpockOpaleye/src/UserServices.hs | 23 +++++++++++++++++++++++ 3 files changed, 26 insertions(+), 8 deletions(-) create mode 100644 SpockOpaleye/src/UserServices.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 3004033..1768ee0 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -25,6 +25,7 @@ library JsonInstances, Validations, Conf, + UserServices, Email, TH build-depends: base >= 4.7 && < 5 diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index c1a73d9..708b5a2 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -20,6 +20,7 @@ import CryptoDef import qualified Data.Text as T import Data.Time import Prelude hiding (id) +import UserServices data MySession = EmptySession @@ -78,14 +79,7 @@ app = do maybeTenantIncoming <- jsonBody either_newtenant <- runQuery $ runAppM $ do case maybeTenantIncoming of - Just incomingTenant -> do - result <- validateIncomingTenant incomingTenant - case result of - Valid -> do - newTenant <- createTenant incomingTenant - liftIO $ sendTenantActivationMail newTenant - return $ Right newTenant - Invalid err -> return $ Left $ T.pack ("Validation fail with " <> err) + Just incomingTenant -> doCreateTenant incomingTenant Nothing -> return $ Left $ T.pack "Unrecognized input" case either_newtenant of Right new_tenant -> json new_tenant diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs new file mode 100644 index 0000000..4b48971 --- /dev/null +++ b/SpockOpaleye/src/UserServices.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module UserServices where + +import Control.Lens +import ApiBase +import Email +import DataTypes +import qualified Data.Text as T +import Data.Monoid +import Control.Monad.IO.Class +import Validations +import TenantApi + +doCreateTenant :: TenantIncoming -> AppM (Either T.Text (Auditable Tenant)) +doCreateTenant incomingTenant = do + result <- validateIncomingTenant incomingTenant + case result of + Valid -> do + newTenant <- createTenant incomingTenant + liftIO $ sendTenantActivationMail newTenant + return $ Right newTenant + Invalid err -> return $ Left $ T.concat ["Validation fail with ", T.pack err] From 87b9674b051e55b529b4bdc17bab70a59347e3f0 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 9 Dec 2016 09:39:50 +0000 Subject: [PATCH 55/69] Review modifications --- ServantOpaleye/stack.yaml | 2 +- SpockOpaleye/SpockOpaleye.cabal | 2 + .../tenant-activation-text.tpl | 7 +++ .../email-templates/tenant-activation.tpl | 4 +- SpockOpaleye/src/Email.hs | 55 +++++++++---------- 5 files changed, 38 insertions(+), 32 deletions(-) create mode 100644 SpockOpaleye/email-templates/tenant-activation-text.tpl diff --git a/ServantOpaleye/stack.yaml b/ServantOpaleye/stack.yaml index b3caacb..9959759 100644 --- a/ServantOpaleye/stack.yaml +++ b/ServantOpaleye/stack.yaml @@ -63,4 +63,4 @@ extra-package-dbs: [] # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +# compiler-check: newer-minor diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 1768ee0..0458711 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -31,6 +31,7 @@ library build-depends: base >= 4.7 && < 5 ,smtp-mail ,here + ,filepath ,mime-mail ,product-profunctors ,profunctors @@ -61,6 +62,7 @@ executable SpockOpaleye-exe , postgresql-simple , here , mime-mail + , filepath , smtp-mail , network , old-time diff --git a/SpockOpaleye/email-templates/tenant-activation-text.tpl b/SpockOpaleye/email-templates/tenant-activation-text.tpl new file mode 100644 index 0000000..8738cba --- /dev/null +++ b/SpockOpaleye/email-templates/tenant-activation-text.tpl @@ -0,0 +1,7 @@ +Hi, + Thank you for your registration. You can login +at www.abc.com using your username and password. +Hope to see you soon. + +Regards, +abc.com diff --git a/SpockOpaleye/email-templates/tenant-activation.tpl b/SpockOpaleye/email-templates/tenant-activation.tpl index 8cf52e4..b661524 100644 --- a/SpockOpaleye/email-templates/tenant-activation.tpl +++ b/SpockOpaleye/email-templates/tenant-activation.tpl @@ -283,7 +283,7 @@
- +
@@ -296,7 +296,7 @@ - +
Click here to activate Click here to activate
diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index d0b9c4d..181cae9 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -16,54 +16,51 @@ import Data.String import Data.String.Here import qualified Data.Text as T import qualified Data.Text.Lazy as LT +import qualified Data.ByteString.Lazy as L import DataTypes +import System.FilePath (takeFileName) sendgridMail :: Mail -> IO () sendgridMail mail = do threadId <- forkIO $ sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail - putStrLn $ show $ T.concat ["Sending main from thread ", fromString $ show threadId] + putStrLn $ show $ T.concat ["Sending mail from thread ", fromString $ show threadId] -setCid :: T.Text -> T.Text -> Mail -> Mail -setCid filename cid mail@Mail {mailParts = alternatives} = mail { mailParts = (setCidInAlternative filename cid) <$> alternatives} +addAttachmentCid :: T.Text + -> FilePath + -> T.Text + -> Mail + -> IO Mail +addAttachmentCid ct fn cid mail = do + part <- makePart + return $ addPart [part] mail where - setCidInAlternative :: T.Text -> T.Text -> Alternatives -> Alternatives - setCidInAlternative fp cid parts = (setCidForPart filename cid) <$> parts - setCidForPart :: T.Text -> T.Text -> Part -> Part - setCidForPart filename cid p@Part{partFilename = Just fn, partHeaders = ph} = - if fn == filename then p{partHeaders = (makeContentIdHeader cid):ph} else p - setCidForPart filename cid p = p - makeContentIdHeader :: T.Text -> (ByteString, T.Text) - makeContentIdHeader cid = ("Content-ID", T.concat ["<", cid, ">"]) + header = ("Content-ID", T.concat ["<", cid, ">"]) + filename = T.pack (takeFileName fn) + makePart = do + content <- L.readFile fn + return $ Part ct Base64 (Just filename) [header] content addLogo :: Mail -> IO Mail -addLogo mail = do - mail_with_attachment <- addAttachment "image/png" "apple.png" mail - return $ setCid "apple.png" "logocid" mail_with_attachment +addLogo mail = addAttachmentCid "image/png" "apple.png" "logocid@haskellwebapps.com" mail sendTenantActivationMail :: Auditable Tenant -> IO () sendTenantActivationMail newTenant = do - makeMail from to activation_link >>= addLogo >>= sendgridMail + makeMail from to activationLink >>= addLogo >>= sendgridMail where -- @TODO Make key random key :: T.Text key = "cmFuZG9tdyBlaXJqd28gZWlyandvZWlyaiB3b2VyaWpvd2Vpcmogb3F3ZWlyb3F3ZWl1aHIgb3dxZXVoaXJ3b2Vpcmggb3dldWZob2kgcmV1d2ZpcmVxdWZoaXFld3VyaG9wIHF3dWh3aQ==" - activation_link :: T.Text - activation_link = T.concat ["http://haskellwebapps.vacationlabs.com/activateTenantKey/", key] + activationLink :: T.Text + activationLink = T.concat ["http://haskellwebapps.vacationlabs.com/activateTenantKey/", key] from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} - to = Address { addressName = Just $ T.concat [tenant_fname, " ", tenant_lname], addressEmail = tenant_email} - tenant_fname = (newTenant ^. firstname ) - tenant_lname = (newTenant ^. lastname ) - tenant_email = (newTenant ^. email ) + to = Address { addressName = Just $ T.concat [tenantFname, " ", tenantLname], addressEmail = tenantEmail} + tenantFname = (newTenant ^. firstname ) + tenantLname = (newTenant ^. lastname ) + tenantEmail = (newTenant ^. email ) makeMail :: Address -> Address -> T.Text -> IO Mail - makeMail from to activation_link = simpleMail to from subject text (LT.fromStrict html) [] + makeMail from to activationLink = simpleMail to from subject text (LT.fromStrict html) [] where subject = "Registration Email from abc.com" - text = [iTrim| - Hi, - Thank you for your registration. You can login - at www.abc.com using your username and password. - Hope to see you soon. - Regards, - abc.com|] + text = [template|email-templates/tenant-activation-text.tpl|] html :: T.Text html = [template|email-templates/tenant-activation.tpl|] From 81f6fab29f5dc3dd17827df8116d6c9e88bac002 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 9 Dec 2016 15:26:21 +0000 Subject: [PATCH 56/69] Cleaned up stack.yaml --- SpockOpaleye/stack.yaml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index 427fa3f..097f686 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -46,8 +46,7 @@ packages: - reroute # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: - - SMTPClient-1.1.0 +extra-deps: [] # Override default flag values for local packages and extra-deps flags: {} @@ -68,7 +67,7 @@ extra-package-dbs: [] # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] -extra-lib-dirs: [/usr/lib] +extra-lib-dirs: [] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor From 0a8c9978813df3d54c6e590a37e4a97e83acc28d Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 12 Dec 2016 07:37:15 +0000 Subject: [PATCH 57/69] Use the updated mime-email library --- SpockOpaleye/SpockOpaleye.cabal | 2 +- SpockOpaleye/src/Email.hs | 15 --------------- SpockOpaleye/stack.yaml | 3 ++- 3 files changed, 3 insertions(+), 17 deletions(-) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 0458711..54c7ef5 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -32,7 +32,7 @@ library ,smtp-mail ,here ,filepath - ,mime-mail + ,mime-mail >= 0.4.12 ,product-profunctors ,profunctors ,bytestring diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 181cae9..3eaa8c1 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -25,21 +25,6 @@ sendgridMail mail = do threadId <- forkIO $ sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail putStrLn $ show $ T.concat ["Sending mail from thread ", fromString $ show threadId] -addAttachmentCid :: T.Text - -> FilePath - -> T.Text - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = do - part <- makePart - return $ addPart [part] mail - where - header = ("Content-ID", T.concat ["<", cid, ">"]) - filename = T.pack (takeFileName fn) - makePart = do - content <- L.readFile fn - return $ Part ct Base64 (Just filename) [header] content - addLogo :: Mail -> IO Mail addLogo mail = addAttachmentCid "image/png" "apple.png" "logocid@haskellwebapps.com" mail diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index 097f686..77b5b98 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -46,7 +46,8 @@ packages: - reroute # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: +- mime-mail-0.4.12 # Override default flag values for local packages and extra-deps flags: {} From 29a8a809d2267f336d059cfa0417bb6086c51343 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Mon, 12 Dec 2016 23:29:35 +0000 Subject: [PATCH 58/69] Wrapped the app monad around ExceptT to enable handling of uncaught exceptions in main --- SpockOpaleye/app/Main.hs | 19 ++++++++++++------- SpockOpaleye/src/DataTypes.hs | 7 ++++++- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 708b5a2..9bde0bd 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -21,6 +21,7 @@ import qualified Data.Text as T import Data.Time import Prelude hiding (id) import UserServices +import Control.Monad.Trans.Except data MySession = EmptySession @@ -39,12 +40,16 @@ main = do DummyAppState runSpock 8080 (spock spockCfg app) -runAppM :: AppM a -> Connection -> IO a +runAppM :: AppM a -> Connection -> IO (AppResult a) runAppM x conn = do + putStrLn "request" user <- getTestUser - (item, lg) <- runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) - putStrLn lg - return item + r <- runExceptT $ runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) + case r of + Right (item, lg) -> do + putStrLn lg + return $ AppOk item + Left ex -> return $ AppErr "There was an error" getTestTenant :: Tenant getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" @@ -72,7 +77,7 @@ getTestUser = do app :: SpockM Connection MySession MyAppState () app = do get ("tenants") $ do - tenants <- runQuery $ runAppM $ readTenants + AppOk tenants <- runQuery $ runAppM $ readTenants json tenants post ("tenants/new") $ do @@ -82,5 +87,5 @@ app = do Just incomingTenant -> doCreateTenant incomingTenant Nothing -> return $ Left $ T.pack "Unrecognized input" case either_newtenant of - Right new_tenant -> json new_tenant - Left message -> json message + AppOk (Right new_tenant) -> json new_tenant + AppOk (Left message) -> json message diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index a96b864..8f60360 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -21,7 +21,12 @@ import GHC.Generics import Data.Aeson (Value(..)) import qualified Data.HashMap.Strict as HM -type AppM a = WriterT String (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) IO) a +import Control.Exception +import Control.Monad.Trans.Except + +type AppM a = WriterT String (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) (ExceptT SomeException IO)) a + +data AppResult a = AppOk a | AppErr Text getConnection :: AppM Connection getConnection = do From 65c5cccdca143b5e6815d452dbd236d7aef1f50d Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 13 Dec 2016 13:48:19 +0000 Subject: [PATCH 59/69] Trying to add request body to the error logs --- SpockOpaleye/SpockOpaleye.cabal | 5 +++++ SpockOpaleye/app/Main.hs | 13 ++++++++++--- SpockOpaleye/src/ApiBase.hs | 3 ++- SpockOpaleye/src/DataTypes.hs | 3 ++- SpockOpaleye/src/UserServices.hs | 2 ++ SpockOpaleye/stack.yaml | 1 + 6 files changed, 22 insertions(+), 5 deletions(-) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 54c7ef5..e0906e9 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -30,6 +30,8 @@ library TH build-depends: base >= 4.7 && < 5 ,smtp-mail + ,lifted-base + ,airbrake ,here ,filepath ,mime-mail >= 0.4.12 @@ -52,6 +54,7 @@ library ,aeson ,unordered-containers ,template-haskell + ,lifted-base default-language: Haskell2010 executable SpockOpaleye-exe @@ -60,6 +63,7 @@ executable SpockOpaleye-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: base , postgresql-simple + , airbrake , here , mime-mail , filepath @@ -77,6 +81,7 @@ executable SpockOpaleye-exe , vector , aeson , unordered-containers + , lifted-base default-language: Haskell2010 test-suite SpockOpaleye-test diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 9bde0bd..af6a52d 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -22,6 +22,8 @@ import Data.Time import Prelude hiding (id) import UserServices import Control.Monad.Trans.Except +import Control.Exception.Lifted +import Airbrake data MySession = EmptySession @@ -44,12 +46,16 @@ runAppM :: AppM a -> Connection -> IO (AppResult a) runAppM x conn = do putStrLn "request" user <- getTestUser - r <- runExceptT $ runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) + r <- runExceptT $ handle throwE $ runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) case r of Right (item, lg) -> do - putStrLn lg return $ AppOk item - Left ex -> return $ AppErr "There was an error" + Left ex -> do + let message = T.pack $ show ex + notify conf (Error "Uncaught exception" message) (("sdfsfd", 5):|[]) + return $ AppErr message + where + conf = airbrakeConf "61a1adfc070a9be9f21e43f586bbf5f7" "Env" getTestTenant :: Tenant getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" @@ -89,3 +95,4 @@ app = do case either_newtenant of AppOk (Right new_tenant) -> json new_tenant AppOk (Left message) -> json message + AppErr _ -> json $ T.pack "There was an error. Please try again later" diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 700067d..5134df3 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -21,13 +21,14 @@ import GHC.Int import Prelude hiding (id) import TH import Data.Aeson (Value(..)) +import Data.ByteString (ByteString) import JsonInstances () makeAuditableLenses ''Role makeAuditableLenses ''Tenant makeAuditableLenses ''User -auditLog :: String -> AppM () +auditLog :: ByteString -> AppM () auditLog = tell removeRawDbRows :: Table columnsW columnsR -> (columnsR -> Column PGBool) -> AppM GHC.Int.Int64 diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 8f60360..e9d227f 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -20,11 +20,12 @@ import Database.PostgreSQL.Simple import GHC.Generics import Data.Aeson (Value(..)) import qualified Data.HashMap.Strict as HM +import Data.ByteString import Control.Exception import Control.Monad.Trans.Except -type AppM a = WriterT String (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) (ExceptT SomeException IO)) a +type AppM a = WriterT ByteString (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) (ExceptT SomeException IO)) a data AppResult a = AppOk a | AppErr Text diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs index 4b48971..39269f5 100644 --- a/SpockOpaleye/src/UserServices.hs +++ b/SpockOpaleye/src/UserServices.hs @@ -18,6 +18,8 @@ doCreateTenant incomingTenant = do case result of Valid -> do newTenant <- createTenant incomingTenant + f <- return (head []) + liftIO $ putStrLn f liftIO $ sendTenantActivationMail newTenant return $ Right newTenant Invalid err -> return $ Left $ T.concat ["Validation fail with ", T.pack err] diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index 77b5b98..d2e1ea3 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -37,6 +37,7 @@ resolver: lts-7.5 # will not be run. This is useful for tweaking upstream packages. packages: - '.' +- hs-airbrake - location: git: https://github.com/agrafix/Spock.git commit: 77333a2de5dea0dc8eba9432ab16864e93e5d70e From 52c102bfa2c0d92520116d2b626298da38ae6d15 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 13 Dec 2016 18:21:33 +0000 Subject: [PATCH 60/69] Use a helper function to fetch env info and log it in case of an exception --- SpockOpaleye/app/Main.hs | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index af6a52d..00deca6 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -24,6 +24,7 @@ import UserServices import Control.Monad.Trans.Except import Control.Exception.Lifted import Airbrake +import Data.ByteString (ByteString) data MySession = EmptySession @@ -44,7 +45,6 @@ main = do runAppM :: AppM a -> Connection -> IO (AppResult a) runAppM x conn = do - putStrLn "request" user <- getTestUser r <- runExceptT $ handle throwE $ runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) case r of @@ -52,10 +52,7 @@ runAppM x conn = do return $ AppOk item Left ex -> do let message = T.pack $ show ex - notify conf (Error "Uncaught exception" message) (("sdfsfd", 5):|[]) return $ AppErr message - where - conf = airbrakeConf "61a1adfc070a9be9f21e43f586bbf5f7" "Env" getTestTenant :: Tenant getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" @@ -79,20 +76,31 @@ getTestUser = do , utctDayTime = secondsToDiffTime 0 } +runWithLogging :: ActionT (WebStateM Connection MySession MyAppState) (AppResult a) + -> (a -> ActionT (WebStateM Connection MySession MyAppState) ()) + -> ActionT (WebStateM Connection MySession MyAppState) () +runWithLogging act sact = do + r <- act + case r of + AppOk rOk -> sact rOk + AppErr msg -> do + b <- body + liftIO $ notify conf (Error "Uncaught exception" msg) (("sdfsfd", 5):|[]) + json $ T.pack "There was an error. Please try again later" + where + conf = airbrakeConf "61a1adfc070a9be9f21e43f586bbf5f7" "Env" app :: SpockM Connection MySession MyAppState () app = do get ("tenants") $ do - AppOk tenants <- runQuery $ runAppM $ readTenants + AppOk tenants <- runQuery $ runAppM readTenants json tenants - post ("tenants/new") $ - do + post ("tenants/new") $ runWithLogging (do maybeTenantIncoming <- jsonBody - either_newtenant <- runQuery $ runAppM $ do + runQuery $ runAppM $ do case maybeTenantIncoming of Just incomingTenant -> doCreateTenant incomingTenant Nothing -> return $ Left $ T.pack "Unrecognized input" - case either_newtenant of - AppOk (Right new_tenant) -> json new_tenant - AppOk (Left message) -> json message - AppErr _ -> json $ T.pack "There was an error. Please try again later" + ) (\et -> case et of + Right new_tenant -> json new_tenant + Left message -> json message) From 0ce8cbf17fefc7312c2419886433bf933fb91b41 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Tue, 13 Dec 2016 19:01:35 +0000 Subject: [PATCH 61/69] Add request info to the log --- SpockOpaleye/app/Main.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 00deca6..5e2e3a8 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -24,6 +24,7 @@ import UserServices import Control.Monad.Trans.Except import Control.Exception.Lifted import Airbrake +import Airbrake.WebRequest import Data.ByteString (ByteString) data MySession = @@ -84,8 +85,8 @@ runWithLogging act sact = do case r of AppOk rOk -> sact rOk AppErr msg -> do - b <- body - liftIO $ notify conf (Error "Uncaught exception" msg) (("sdfsfd", 5):|[]) + r <- request + liftIO $ notifyReq conf (waiRequestToRequest r) (Error "Uncaught exception" msg) (("Filename", 5):|[]) json $ T.pack "There was an error. Please try again later" where conf = airbrakeConf "61a1adfc070a9be9f21e43f586bbf5f7" "Env" @@ -93,8 +94,7 @@ runWithLogging act sact = do app :: SpockM Connection MySession MyAppState () app = do get ("tenants") $ do - AppOk tenants <- runQuery $ runAppM readTenants - json tenants + runWithLogging (runQuery $ runAppM readTenants) (\tenants ->json tenants) post ("tenants/new") $ runWithLogging (do maybeTenantIncoming <- jsonBody runQuery $ runAppM $ do From cd991a1ca21348517e8f85a3c9668c794f25adc7 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 14 Dec 2016 08:43:02 +0000 Subject: [PATCH 62/69] Added airbrake source --- SpockOpaleye/hs-airbrake/.gitignore | 4 + SpockOpaleye/hs-airbrake/.travis.yml | 8 + SpockOpaleye/hs-airbrake/LICENSE | 26 +++ SpockOpaleye/hs-airbrake/README.md | 1 + SpockOpaleye/hs-airbrake/Setup.hs | 2 + SpockOpaleye/hs-airbrake/airbrake.cabal | 35 +++ SpockOpaleye/hs-airbrake/default.nix | 18 ++ SpockOpaleye/hs-airbrake/release.nix | 15 ++ SpockOpaleye/hs-airbrake/src/Airbrake.hs | 205 ++++++++++++++++++ .../hs-airbrake/src/Airbrake/Credentials.hs | 84 +++++++ .../hs-airbrake/src/Airbrake/WebRequest.hs | 50 +++++ 11 files changed, 448 insertions(+) create mode 100644 SpockOpaleye/hs-airbrake/.gitignore create mode 100644 SpockOpaleye/hs-airbrake/.travis.yml create mode 100644 SpockOpaleye/hs-airbrake/LICENSE create mode 100644 SpockOpaleye/hs-airbrake/README.md create mode 100644 SpockOpaleye/hs-airbrake/Setup.hs create mode 100644 SpockOpaleye/hs-airbrake/airbrake.cabal create mode 100644 SpockOpaleye/hs-airbrake/default.nix create mode 100644 SpockOpaleye/hs-airbrake/release.nix create mode 100644 SpockOpaleye/hs-airbrake/src/Airbrake.hs create mode 100644 SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs create mode 100644 SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs diff --git a/SpockOpaleye/hs-airbrake/.gitignore b/SpockOpaleye/hs-airbrake/.gitignore new file mode 100644 index 0000000..9a14ea8 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/.gitignore @@ -0,0 +1,4 @@ +dist +.cabal-sandbox +cabal.sandbox.config +result diff --git a/SpockOpaleye/hs-airbrake/.travis.yml b/SpockOpaleye/hs-airbrake/.travis.yml new file mode 100644 index 0000000..4196689 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/.travis.yml @@ -0,0 +1,8 @@ +language: haskell + +install: + - cabal update + - cabal install --only-dependencies + +script: + - cabal test diff --git a/SpockOpaleye/hs-airbrake/LICENSE b/SpockOpaleye/hs-airbrake/LICENSE new file mode 100644 index 0000000..3f8829d --- /dev/null +++ b/SpockOpaleye/hs-airbrake/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Joel Taylor +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/SpockOpaleye/hs-airbrake/README.md b/SpockOpaleye/hs-airbrake/README.md new file mode 100644 index 0000000..e20c580 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/README.md @@ -0,0 +1 @@ +[![Build status](https://travis-ci.org/pikajude/hs-airbrake.svg)](http://travis-ci.org/pikajude/hs-airbrake) diff --git a/SpockOpaleye/hs-airbrake/Setup.hs b/SpockOpaleye/hs-airbrake/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/SpockOpaleye/hs-airbrake/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SpockOpaleye/hs-airbrake/airbrake.cabal b/SpockOpaleye/hs-airbrake/airbrake.cabal new file mode 100644 index 0000000..2d572a8 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/airbrake.cabal @@ -0,0 +1,35 @@ +name: airbrake +version: 0.2.0.0 +synopsis: An Airbrake notifier for Haskell +description: Airbrake notifier. +homepage: https://github.com/joelteon/airbrake +license: BSD3 +license-file: LICENSE +author: Joel Taylor +maintainer: me@joelt.io +category: Network +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Airbrake, Airbrake.WebRequest, Airbrake.Credentials + other-modules: Paths_airbrake + build-depends: base == 4.* + , blaze-markup + , bytestring + , directory + , exceptions + , filepath + , http-conduit + , monad-control + , network >= 2.6 + , network-uri + , semigroups + , template-haskell + , text + , transformers + , utf8-string + , wai + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 diff --git a/SpockOpaleye/hs-airbrake/default.nix b/SpockOpaleye/hs-airbrake/default.nix new file mode 100644 index 0000000..cfa6a66 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/default.nix @@ -0,0 +1,18 @@ +{ mkDerivation, base, blaze-markup, bytestring, directory +, exceptions, filepath, http-conduit, monad-control, network +, network-uri, semigroups, stdenv, template-haskell, text +, transformers, utf8-string, wai +}: +mkDerivation { + pname = "airbrake"; + version = "0.2.0.0"; + src = ./.; + libraryHaskellDepends = [ + base blaze-markup bytestring directory exceptions filepath + http-conduit monad-control network network-uri semigroups + template-haskell text transformers utf8-string wai + ]; + homepage = "https://github.com/joelteon/airbrake"; + description = "An Airbrake notifier for Haskell"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/SpockOpaleye/hs-airbrake/release.nix b/SpockOpaleye/hs-airbrake/release.nix new file mode 100644 index 0000000..1cf6bbf --- /dev/null +++ b/SpockOpaleye/hs-airbrake/release.nix @@ -0,0 +1,15 @@ +{ supportedPlatforms ? [ "x86_64-linux" "x86_64-darwin" ] +, supportedCompilers ? ["ghc6104" "ghc6123" "ghc704" "ghc722" "ghc742" "ghc763" "ghc783" "ghcHEAD"] +}: + +let + genAttrs = (import {}).lib.genAttrs; +in +{ + airbrake = genAttrs supportedCompilers (ghcVer: genAttrs supportedPlatforms (system: + let + pkgs = import { inherit system; }; + haskellPackages = pkgs.lib.getAttrFromPath ["haskellPackages_${ghcVer}"] pkgs; + in haskellPackages.callPackage ./default.nix {} + )); +} diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake.hs b/SpockOpaleye/hs-airbrake/src/Airbrake.hs new file mode 100644 index 0000000..a4227f4 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | Utilities for notifying Airbrake of errors. An 'Error' type is +-- provided; you can convert any instance of 'Exception' to an 'Error' +-- using 'toError', which uses the exception's 'Typeable' instance. +-- +-- Airbrake requires a stack trace for any reported exception, but stack +-- trace information isn't readily available for Haskell exceptions. +-- 'notifyQ' and 'notifyReqQ' are provided for the purpose of providing the +-- current file position as the stack trace. +module Airbrake ( + -- * Notifying + notify, notifyReq, + notifyQ, notifyReqQ, + + -- * Notification metadata + -- *** Location lists + NonEmpty (..), Location, Locations, + + -- *** Wrapping errors + toError, Error (..), + + -- * Configuration building + APIKey, Environment, + airbrakeConf, defaultApiEndpoint, + AirbrakeConf (..), + Server (..), + + -- * Convenience exports + module Airbrake.Credentials +) where + +import Airbrake.Credentials hiding (APIKey) +import qualified Airbrake.WebRequest as W +import Control.Exception +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.ByteString.Lazy (ByteString) +import Data.Foldable +import Data.List.NonEmpty +import Data.String +import Data.Text (pack) +import qualified Data.Text as T (Text) +import Data.Typeable (typeOf) +import Data.Version +import Language.Haskell.TH.Syntax hiding (report) +import Network.HTTP.Conduit +import qualified Paths_airbrake as P +import Prelude hiding (error) +import Text.Blaze +import Text.Blaze.Internal +import Text.Blaze.Renderer.Utf8 + +type APIKey = String +type Environment = String + +data Error = Error + { errorType :: T.Text + , errorDescription :: T.Text + } + +-- | Information to use when communicating with Airbrake. +data AirbrakeConf = AirbrakeConf + { acApiEndpoint :: String + , acApiKey :: APIKey + , acServer :: Server + } + +-- | Metadata about the server. +data Server = Server + { serverEnvironment :: Environment + , serverAppVersion :: Maybe Version + , serverRoot :: Maybe FilePath + } + +-- | A @(filename, line)@ pair. +type Location = (FilePath, Int) + +type Locations = NonEmpty Location + +-- | @"http:\/\/api.airbrake.io\/notifier_api\/v2\/notices"@ +defaultApiEndpoint :: String +defaultApiEndpoint = "http://api.airbrake.io/notifier_api/v2/notices" + +airbrakeConf :: APIKey -> Environment -> AirbrakeConf +airbrakeConf k env = + AirbrakeConf defaultApiEndpoint k (Server env Nothing Nothing) + +performNotify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => Locations -> AirbrakeConf -> Maybe W.WebRequest -> Error -> m () +performNotify loc conf req e = do + let report = buildReport loc conf req e + req' <- parseUrl (acApiEndpoint conf) + let rq = req' { requestBody = RequestBodyLBS report, method = "POST" } + man <- liftIO $ newManager tlsManagerSettings + _ <- httpLbs rq man + return () + +-- | Notify Airbrake of an exception. +notify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => AirbrakeConf -> Error -> Locations -> m () +notify conf e l = performNotify l conf Nothing e + +-- | Notify Airbrake of an exception, providing request metadata along with +-- it. +notifyReq :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => AirbrakeConf -> W.WebRequest -> Error -> Locations -> m () +notifyReq conf req e l = performNotify l conf (Just req) e + +-- | 'notify', fetching the current file location using Template Haskell. +-- +-- @ +-- $notifyQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m) +-- => 'AirbrakeConf' -> 'Error' -> m () +-- @ +notifyQ :: Q Exp +notifyQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc ee -> notify cc ee ((fn, st) :| []) |] + +-- | 'notifyReq', fetching the current file location using Template +-- Haskell. +-- +-- @ +-- $notifyReqQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m, 'W.WebRequest' req) +-- => 'AirbrakeConf' -> req -> 'Error' -> m () +-- @ +notifyReqQ :: Q Exp +notifyReqQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc r ee -> notifyReq cc r ee ((fn, st) :| []) |] + +-- | Convert any 'Exception' to an 'Error'. +toError :: Exception e => e -> Error +toError (toException -> SomeException e) = + Error (pack (show (typeOf e))) (pack (show e)) + +buildReport :: Locations -> AirbrakeConf -> Maybe W.WebRequest -> Error -> ByteString +buildReport locs conf req err = renderMarkup $ do + preEscapedText "" + notice ! nversion "2.3" $ do + api_key . toMarkup $ acApiKey conf + + notifier $ do + name "airbrake" + version . toMarkup $ showVersion P.version + url "http://hackage.haskell.org/package/airbrake" + + error $ do + class_ (toMarkup (errorType err)) + message (toMarkup (errorDescription err)) + backtrace $ forM_ locs $ \ (filename, line') -> + line ! file (toValue filename) + ! number (toValue line') + + forM_ req $ \ r -> request $ do + url (toMarkup . show $ W.requestUrl r) + forM_ (W.requestRoute r) $ \ rt -> component (toMarkup rt) + forM_ (W.requestAction r) $ \ act -> action (toMarkup act) + cgi_data . forM_ (W.requestOtherVars r) $ \ (k, v) -> + var ! key (toValue k) $ toMarkup v + + let serv = acServer conf + server_environment $ do + environment_name . toMarkup $ serverEnvironment serv + forM_ (serverAppVersion serv) $ \ v -> + app_version (toMarkup $ showVersion v) + + forM_ (serverRoot serv) $ \ v -> + project_root (toMarkup v) + where + notice = Parent "notice" "" + name = Parent "name" "" + notifier = Parent "notifier" "" + api_key = Parent "api-key" "" + version = Parent "version" "" + url = Parent "url" "" + class_ = Parent "class" "" + error = Parent "error" "" + message = Parent "message" "" + backtrace = Parent "backtrace" "" + line = Leaf "line" "" + file = attribute "file" " file=\"" + number = attribute "number" " number=\"" + server_environment = Parent "server-environment" "" + environment_name = Parent "environment-name" "" + app_version = Parent "app-version" "" + project_root = Parent "project-root" "" + request = Parent "request" "" + cgi_data = Parent "cgi-data" "" + action = Parent "action" "" + component = Parent "component" "" + var = Parent "var" "" + key = attribute "key" " key=\"" + nversion = attribute "version" " version=\"" diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs b/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs new file mode 100644 index 0000000..6c311a1 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +-- | Utilities for loading the API key from the environment. +module Airbrake.Credentials ( + APIKey, + credentialsDefaultFile, credentialsDefaultKey, + loadCredentialsFromFile, loadCredentialsFromEnv, + loadCredentialsFromEnvOrFile, loadCredentialsDefault +) where + +import Control.Monad (liftM) +import Control.Monad.IO.Class +import Data.List (find) +import System.Directory +import System.Environment +import System.FilePath + +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative ((<$>)) +#endif + +type APIKey = String + +-- | The file where API credentials are loaded when using +-- 'loadCredentialsDefault'. +-- +-- Default: @$HOME/.airbrake-keys@ +credentialsDefaultFile :: MonadIO m => m FilePath +credentialsDefaultFile = liftIO $ liftM ( ".airbrake-keys") getHomeDirectory + +-- | The key to be used in the loaded API credentials file, when using +-- 'loadCredentialsDefault'. +-- +-- Default: @default@ +credentialsDefaultKey :: String +credentialsDefaultKey = "default" + +-- | Load API credentials from a text file given a key name. +-- +-- The file should consist of newline-separated credentials in the +-- following format: +-- +-- @keyName apiKey@ +loadCredentialsFromFile :: MonadIO m => FilePath -> String -> m (Maybe APIKey) +loadCredentialsFromFile file key = liftIO $ do + contents <- map words . lines <$> readFile file + return $ do + [_k, apikey] <- find (hasKey key) contents + return apikey + where + hasKey _ [] = False + hasKey k (k2 : _) = k == k2 + +-- | Load API credentials from the environment if possible, or alternately +-- from the default file with the default key name. +-- +-- Default file: @$HOME/.airbrake-keys@ +-- +-- Default key: @default@ +-- +-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile'. +loadCredentialsDefault :: MonadIO m => m (Maybe APIKey) +loadCredentialsDefault = do + file <- credentialsDefaultFile + loadCredentialsFromEnvOrFile file credentialsDefaultKey + +-- | Load API credentials from the environment variable @AIRBRAKE_API_KEY@. +loadCredentialsFromEnv :: MonadIO m => m (Maybe APIKey) +loadCredentialsFromEnv = liftIO $ do + env <- getEnvironment + let lk = flip lookup env + key = lk "AIRBRAKE_API_KEY" + return key + +-- | Load API credentials from the environment, or, failing that, from the +-- given file with the given key name. +-- +-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile'. +loadCredentialsFromEnvOrFile :: MonadIO m => FilePath -> String -> m (Maybe APIKey) +loadCredentialsFromEnvOrFile file key = do + envcr <- loadCredentialsFromEnv + case envcr of + Just cr -> return (Just cr) + Nothing -> loadCredentialsFromFile file key diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs b/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs new file mode 100644 index 0000000..4a88544 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A datatype representing the request attributes Airbrake wants to hear +-- about. Conversion functions are provided for: +-- +-- * wai +module Airbrake.WebRequest ( + WebRequest (..), waiRequestToRequest +) where + +import Data.ByteString.UTF8 (toString) +import Data.Maybe +import Network.URI +import qualified Network.Wai as Wai + +data WebRequest = WebRequest + { + -- | The request URL. + requestUrl :: URI + -- | Current route. + -- This is a carryover from Rails-style MVC and is optional. + , requestRoute :: Maybe String + -- | Controller action being used. + -- This is a carryover from Rails-style MVC and is optional. + , requestAction :: Maybe String + -- | Any other request metadata that you would like to include + -- (server name, user agent, etc.) + , requestOtherVars :: [(String, String)] + } deriving (Eq, Ord, Show) + +waiRequestToRequest :: Wai.Request -> WebRequest +waiRequestToRequest req = WebRequest{..} where + requestUrl = fromMaybe + (error "Failure producing URI from wai request.") + (parseURI uriS) + uriS = (if Wai.isSecure req then "https://" else "http://") + ++ show (Wai.remoteHost req) + ++ toString (Wai.rawPathInfo req) + ++ toString (Wai.rawQueryString req) + requestRoute = Nothing + requestAction = Nothing + requestOtherVars = catMaybes + [ k "Host" "HTTP_HOST" + , k "User-Agent" "HTTP_USER_AGENT" + , k "Referer" "HTTP_REFERER" + , k "Cookie" "HTTP_COOKIE" + , if Wai.isSecure req then Just ("HTTPS", "on") else Nothing] + where k hdr key = fmap (\ v -> (key, toString v)) + (lookup hdr (Wai.requestHeaders req)) From e788e65ae49d9e503c4a8f13501c86716aeef6ce Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Wed, 14 Dec 2016 08:46:24 +0000 Subject: [PATCH 63/69] cabale file update --- SpockOpaleye/SpockOpaleye.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index e0906e9..bd05fa2 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -64,6 +64,7 @@ executable SpockOpaleye-exe build-depends: base , postgresql-simple , airbrake + , bytestring , here , mime-mail , filepath From 6ec820bd61509fde2a917e20a27c95682f255cc7 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 15 Dec 2016 12:01:08 +0000 Subject: [PATCH 64/69] Wrap the auditable types --- SpockOpaleye/app/Main.hs | 24 +---------------- SpockOpaleye/src/ApiBase.hs | 6 ++--- SpockOpaleye/src/DataTypes.hs | 43 ++++++++++++++++++++++++------- SpockOpaleye/src/Email.hs | 2 +- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/RoleAPi.hs | 8 +++--- SpockOpaleye/src/TenantApi.hs | 18 ++++++------- SpockOpaleye/src/UserApi.hs | 18 ++++++------- SpockOpaleye/src/UserServices.hs | 2 +- SpockOpaleye/src/Validations.hs | 2 +- 10 files changed, 63 insertions(+), 62 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 5e2e3a8..72d42a4 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -47,7 +47,7 @@ main = do runAppM :: AppM a -> Connection -> IO (AppResult a) runAppM x conn = do user <- getTestUser - r <- runExceptT $ handle throwE $ runReaderT (runWriterT x) (conn, Just $ auditable getTestTenant, Just $ auditable user) + r <- runExceptT $ handle throwE $ runReaderT (runWriterT x) (conn, Just $ getTestTenant, Just $ user) case r of Right (item, lg) -> do return $ AppOk item @@ -55,28 +55,6 @@ runAppM x conn = do let message = T.pack $ show ex return $ AppErr message -getTestTenant :: Tenant -getTestTenant = Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" - where - tz = UTCTime { - utctDay = ModifiedJulianDay { - toModifiedJulianDay = 0 - } - , utctDayTime = secondsToDiffTime 0 - } - -getTestUser :: IO User -getTestUser = do - Just password_ <- bcryptPassword "adsasda" - return $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive - where - tz = UTCTime { - utctDay = ModifiedJulianDay { - toModifiedJulianDay = 0 - } - , utctDayTime = secondsToDiffTime 0 - } - runWithLogging :: ActionT (WebStateM Connection MySession MyAppState) (AppResult a) -> (a -> ActionT (WebStateM Connection MySession MyAppState) ()) -> ActionT (WebStateM Connection MySession MyAppState) () diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 5134df3..007e30e 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -24,9 +24,9 @@ import Data.Aeson (Value(..)) import Data.ByteString (ByteString) import JsonInstances () -makeAuditableLenses ''Role -makeAuditableLenses ''Tenant -makeAuditableLenses ''User +makeAuditableLenses ''InternalRole +makeAuditableLenses ''InternalTenant +makeAuditableLenses ''InternalUser auditLog :: ByteString -> AppM () auditLog = tell diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index e9d227f..2c68544 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} module DataTypes where @@ -24,8 +25,9 @@ import Data.ByteString import Control.Exception import Control.Monad.Trans.Except +import Data.Time -type AppM a = WriterT ByteString (ReaderT (Connection, Maybe (Auditable Tenant), Maybe (Auditable User)) (ExceptT SomeException IO)) a +type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a data AppResult a = AppOk a | AppErr Text @@ -34,12 +36,12 @@ getConnection = do (conn, _, _) <- R.ask return conn -getCurrentTenant :: AppM (Maybe (Auditable Tenant)) +getCurrentTenant :: AppM (Maybe Tenant) getCurrentTenant = do (_, tenant, _) <- R.ask return tenant -getCurrentUser :: AppM (Maybe (Auditable User)) +getCurrentUser :: AppM (Maybe User) getCurrentUser = do (_, _, user) <- R.ask return user @@ -68,7 +70,18 @@ data TenantPoly key created_at updated_at name fname lname email phone status ow } deriving (Show, Generic) -type Tenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text +type InternalTenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text +type Tenant = Auditable InternalTenant + +getTestTenant :: Tenant +getTestTenant = auditable $ Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } type TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text @@ -90,7 +103,20 @@ data UserPoly key created_at updated_at tenant_id username password firstname la , _userpolyStatus :: status } deriving (Show) -type User = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus +type InternalUser = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus +type User = Auditable InternalUser + +getTestUser :: IO User +getTestUser = do + Just password_ <- bcryptPassword "adsasda" + return $ auditable $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) () @@ -109,7 +135,8 @@ data RolePoly key tenant_id name permission created_at updated_at = Role { , _rolepolyUpdatedat :: updated_at } deriving (Show) -type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +type InternalRole = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +type Role = Auditable InternalRole type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) @@ -117,10 +144,6 @@ data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) auditable :: a -> Auditable a auditable a = Auditable {_data = a, _log = Object HM.empty} -type TenantA = Auditable Tenant -type RoleA = Auditable Role -type UserA = Auditable User - wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) wrapAuditable a = (fmap auditable) <$> a diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 3eaa8c1..e82140c 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -28,7 +28,7 @@ sendgridMail mail = do addLogo :: Mail -> IO Mail addLogo mail = addAttachmentCid "image/png" "apple.png" "logocid@haskellwebapps.com" mail -sendTenantActivationMail :: Auditable Tenant -> IO () +sendTenantActivationMail :: Tenant -> IO () sendTenantActivationMail newTenant = do makeMail from to activationLink >>= addLogo >>= sendgridMail where diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 1e808ae..92e6804 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -51,7 +51,7 @@ instance ToJSON TenantStatus where tgModify "TenantStatusNew" = "new" tgModify _ = error "Unknown status name for tenant" -instance ToJSON Tenant where +instance ToJSON InternalTenant where toJSON = genericToJSON defaultOptions toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).removePrefix } where diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index a2b2826..567f144 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -21,13 +21,13 @@ import ApiBase import Control.Lens import Prelude hiding (id) -createRole :: RoleIncoming -> AppM (Auditable Role) +createRole :: RoleIncoming -> AppM Role createRole role = auditable <$> createRow roleTable role updateRole :: Role -> AppM Role -updateRole role = updateRow roleTable role +updateRole role = updateAuditableRow roleTable role -removeRole :: Auditable Role -> AppM GHC.Int.Int64 +removeRole :: Role -> AppM GHC.Int.Int64 removeRole Auditable {_data = role} = do _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) removeRawDbRows roleTable matchFunc @@ -35,7 +35,7 @@ removeRole Auditable {_data = role} = do tId = role ^. id matchFunc role' = (role' ^. id).== constant tId -readRolesForTenant :: TenantId -> AppM [Auditable Role] +readRolesForTenant :: TenantId -> AppM [Role] readRolesForTenant tId = do wrapAuditable $ readRow $ roleQueryForTenant tId diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index ef1a86e..ee92cd4 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -29,24 +29,24 @@ import Prelude hiding (id) import RoleApi import UserApi -createTenant :: TenantIncoming -> AppM (Auditable Tenant) +createTenant :: TenantIncoming -> AppM Tenant createTenant tenant = do auditable <$> createRow tenantTable tenant -activateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) +activateTenant :: Tenant -> AppM Tenant activateTenant tenant = setTenantStatus tenant TenantStatusActive -deactivateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) +deactivateTenant :: Tenant -> AppM Tenant deactivateTenant tenant = setTenantStatus tenant TenantStatusInActive -setTenantStatus :: (Auditable Tenant) -> TenantStatus -> AppM (Auditable Tenant) +setTenantStatus :: Tenant -> TenantStatus -> AppM Tenant setTenantStatus tenant st = updateTenant (tenant & status .~ st) -updateTenant :: (Auditable Tenant) -> AppM (Auditable Tenant) +updateTenant :: Tenant -> AppM Tenant updateTenant tenant = do updateAuditableRow tenantTable tenant -removeTenant :: Auditable Tenant -> AppM GHC.Int.Int64 +removeTenant :: Tenant -> AppM GHC.Int.Int64 removeTenant tenant = do tenant_deac <- deactivateTenant tenant _ <- updateTenant (tenant_deac & ownerid .~ Nothing) @@ -60,14 +60,14 @@ removeTenant tenant = do matchFunc :: TenantTableR -> Column PGBool matchFunc tenant' = (tenant' ^. id) .== (constant tid) -readTenants :: AppM [Auditable Tenant] +readTenants :: AppM [Tenant] readTenants = wrapAuditable $ readRow tenantQuery -readTenantById :: TenantId -> AppM (Maybe (Auditable Tenant)) +readTenantById :: TenantId -> AppM (Maybe Tenant) readTenantById tenantId = do wrapAuditable $ listToMaybe <$> (readRow (tenantQueryById tenantId)) -readTenantByBackofficedomain :: Text -> AppM (Maybe (Auditable Tenant)) +readTenantByBackofficedomain :: Text -> AppM (Maybe Tenant) readTenantByBackofficedomain domain = do wrapAuditable $ listToMaybe <$> (readRow (tenantQueryByBackoffocedomain domain)) diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 6d7b816..39e1d45 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -30,34 +30,34 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) -createUser :: UserIncoming -> AppM (Auditable User) +createUser :: UserIncoming -> AppM User createUser user = do Just hash <- liftIO $ bcryptPassword $ user ^. password let fullUser = user { _userpolyPassword = hash } auditable <$> (createRow userTable fullUser) -updateUser :: Auditable User -> AppM (Auditable User) +updateUser :: User -> AppM User updateUser user = updateAuditableRow userTable user -activateUser :: Auditable User -> AppM (Auditable User) +activateUser :: User -> AppM User activateUser user = setUserStatus user UserStatusActive -deactivateUser :: Auditable User -> AppM (Auditable User) +deactivateUser :: User -> AppM User deactivateUser user = setUserStatus user UserStatusInActive -setUserStatus :: Auditable User -> UserStatus -> AppM (Auditable User) +setUserStatus :: User -> UserStatus -> AppM User setUserStatus user newStatus = updateUser $ user & status .~ newStatus -removeUser :: Auditable User -> AppM GHC.Int.Int64 +removeUser :: User -> AppM GHC.Int.Int64 removeUser Auditable { _data = rUser} = removeRow userTable rUser -readUsers :: AppM [Auditable User] +readUsers :: AppM [User] readUsers = wrapAuditable $ readRow userQuery -readUsersForTenant :: TenantId -> AppM [Auditable User] +readUsersForTenant :: TenantId -> AppM [User] readUsersForTenant tenantId = wrapAuditable $ readRow $ userQueryByTenantid tenantId -readUserById :: UserId -> AppM (Maybe (Auditable User)) +readUserById :: UserId -> AppM (Maybe User) readUserById id' = do wrapAuditable $ listToMaybe <$> (readRow $ userQueryById id') diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs index 39269f5..3febd95 100644 --- a/SpockOpaleye/src/UserServices.hs +++ b/SpockOpaleye/src/UserServices.hs @@ -12,7 +12,7 @@ import Control.Monad.IO.Class import Validations import TenantApi -doCreateTenant :: TenantIncoming -> AppM (Either T.Text (Auditable Tenant)) +doCreateTenant :: TenantIncoming -> AppM (Either T.Text Tenant) doCreateTenant incomingTenant = do result <- validateIncomingTenant incomingTenant case result of diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 16b863c..3012b7b 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -31,6 +31,6 @@ validateIncomingTenant tenant = do check_for_unique_bo_domain :: T.Text -> AppM (Either String ()) check_for_unique_bo_domain domain = v <$> readTenantByBackofficedomain domain where - v :: Maybe (Auditable Tenant) -> Either String () + v :: Maybe Tenant -> Either String () v (Just _) = Left "Duplicate backoffice domain" v _ = Right () From f56c9c5f7157a4b8516e17cd9e92933ef520645e Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Thu, 15 Dec 2016 22:19:48 +0000 Subject: [PATCH 65/69] Got the refactor to compile --- SpockOpaleye/SpockOpaleye.cabal | 9 + SpockOpaleye/app/Main.hs | 17 ++ SpockOpaleye/src/ApiBase.hs | 26 ++- SpockOpaleye/src/DataTypes.hs | 124 +------------ SpockOpaleye/src/Email.hs | 2 + SpockOpaleye/src/JsonInstances.hs | 71 +------- SpockOpaleye/src/Lenses.hs | 22 +++ SpockOpaleye/src/OpaleyeDef.hs | 252 -------------------------- SpockOpaleye/src/Role/RoleDefs.hs | 136 ++++++++++++++ SpockOpaleye/src/RoleAPi.hs | 13 ++ SpockOpaleye/src/TH.hs | 5 +- SpockOpaleye/src/Tenant/TenantDefs.hs | 170 +++++++++++++++++ SpockOpaleye/src/Tenant/TenantId.hs | 39 ++++ SpockOpaleye/src/TenantApi.hs | 4 + SpockOpaleye/src/User/UserDefs.hs | 129 +++++++++++++ SpockOpaleye/src/User/UserId.hs | 47 +++++ SpockOpaleye/src/UserApi.hs | 7 + SpockOpaleye/src/UserServices.hs | 1 + SpockOpaleye/src/Validations.hs | 2 + SpockOpaleye/stack.yaml | 2 + 20 files changed, 636 insertions(+), 442 deletions(-) create mode 100644 SpockOpaleye/src/Lenses.hs create mode 100644 SpockOpaleye/src/Role/RoleDefs.hs create mode 100644 SpockOpaleye/src/Tenant/TenantDefs.hs create mode 100644 SpockOpaleye/src/Tenant/TenantId.hs create mode 100644 SpockOpaleye/src/User/UserDefs.hs create mode 100644 SpockOpaleye/src/User/UserId.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index bd05fa2..534b683 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -15,7 +15,16 @@ cabal-version: >=1.10 library hs-source-dirs: src + ,src/Role + ,src/Tenant + ,src/User exposed-modules: DataTypes, + UserDefs, + TenantDefs, + RoleDefs, + TenantId, + UserId, + Lenses, ApiBase, TenantApi, UserApi, diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 72d42a4..2594afe 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -16,6 +16,7 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer +import qualified Control.Monad.Reader as R import CryptoDef import qualified Data.Text as T import Data.Time @@ -26,12 +27,28 @@ import Control.Exception.Lifted import Airbrake import Airbrake.WebRequest import Data.ByteString (ByteString) +import TenantDefs +import UserDefs data MySession = EmptySession data MyAppState = DummyAppState + +data AppResult a = AppOk a | AppErr T.Text + +getCurrentUser :: AppM (Maybe User) +getCurrentUser = do + (_, _, user) <- R.ask + return user + + +getCurrentTenant :: AppM (Maybe Tenant) +getCurrentTenant = do + (_, tenant, _) <- R.ask + return tenant + connectDb :: IO Connection connectDb = connect defaultConnectInfo { connectDatabase = "haskell-webapps" } diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index 007e30e..b4a8ffc 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -10,6 +10,7 @@ module ApiBase where import Control.Lens import Control.Monad.IO.Class import Control.Monad.Reader +import qualified Control.Monad.Reader as R import Control.Monad.Writer import qualified Data.Profunctor.Product.Default as D import Data.Time (UTCTime, getCurrentTime) @@ -23,13 +24,28 @@ import TH import Data.Aeson (Value(..)) import Data.ByteString (ByteString) import JsonInstances () +import DataTypes +import Lenses +import Database.PostgreSQL.Simple +import UserDefs +import TenantDefs -makeAuditableLenses ''InternalRole -makeAuditableLenses ''InternalTenant -makeAuditableLenses ''InternalUser +getConnection :: AppM Connection +getConnection = do + (conn, _, _) <- R.ask + return conn + +getCurrentUser :: AppM (Maybe User) +getCurrentUser = do + (_, _, user) <- R.ask + return user + + +getCurrentTenant :: AppM (Maybe Tenant) +getCurrentTenant = do + (_, tenant, _) <- R.ask + return tenant -auditLog :: ByteString -> AppM () -auditLog = tell removeRawDbRows :: Table columnsW columnsR -> (columnsR -> Column PGBool) -> AppM GHC.Int.Int64 removeRawDbRows table matchFunc = do diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 2c68544..3c33891 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -13,140 +13,24 @@ import Control.Lens import qualified Control.Monad.Reader as R import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer -import CryptoDef import Data.List.NonEmpty import Data.Text import Data.Time (UTCTime) import Database.PostgreSQL.Simple import GHC.Generics import Data.Aeson (Value(..)) -import qualified Data.HashMap.Strict as HM import Data.ByteString import Control.Exception import Control.Monad.Trans.Except import Data.Time - -type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a - -data AppResult a = AppOk a | AppErr Text - -getConnection :: AppM Connection -getConnection = do - (conn, _, _) <- R.ask - return conn - -getCurrentTenant :: AppM (Maybe Tenant) -getCurrentTenant = do - (_, tenant, _) <- R.ask - return tenant - -getCurrentUser :: AppM (Maybe User) -getCurrentUser = do - (_, _, user) <- R.ask - return user +import TenantDefs +import UserDefs +import TH data ValidationResult = Valid | Invalid String deriving (Eq, Show) -newtype TenantId = TenantId Int - deriving (Show, Generic) - -data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew - 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 InternalTenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text -type Tenant = Auditable InternalTenant - -getTestTenant :: Tenant -getTestTenant = auditable $ Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" - where - tz = UTCTime { - utctDay = ModifiedJulianDay { - toModifiedJulianDay = 0 - } - , utctDayTime = secondsToDiffTime 0 - } - -type TenantIncoming = TenantPoly () () () 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 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 -} deriving (Show) - -type InternalUser = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus -type User = Auditable InternalUser - -getTestUser :: IO User -getTestUser = do - Just password_ <- bcryptPassword "adsasda" - return $ auditable $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive - where - tz = UTCTime { - utctDay = ModifiedJulianDay { - toModifiedJulianDay = 0 - } - , utctDayTime = secondsToDiffTime 0 - } - -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 created_at updated_at = Role { - _rolepolyId :: key - , _rolepolyTenantid :: tenant_id - , _rolepolyName :: name - , _rolepolyPermission :: permission - , _rolepolyCreatedat :: created_at - , _rolepolyUpdatedat :: updated_at -} deriving (Show) - -type InternalRole = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime -type Role = Auditable InternalRole -type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () - -data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) - -auditable :: a -> Auditable a -auditable a = Auditable {_data = a, _log = Object HM.empty} - -wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) -wrapAuditable a = (fmap auditable) <$> a - -makeLensesWith abbreviatedFields ''RolePoly -makeLensesWith abbreviatedFields ''TenantPoly -makeLensesWith abbreviatedFields ''UserPoly +type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index e82140c..8fcb2e9 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -19,6 +19,8 @@ import qualified Data.Text.Lazy as LT import qualified Data.ByteString.Lazy as L import DataTypes import System.FilePath (takeFileName) +import TenantDefs +import Lenses sendgridMail :: Mail -> IO () sendgridMail mail = do diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 92e6804..fbb7169 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -10,69 +10,14 @@ import Data.Char import Data.Text import DataTypes -instance (FromJSON a) => FromJSON (Auditable a) where - parseJSON j = auditable <$> (parseJSON j) - -instance FromJSON UserId where - parseJSON j@(Number _) = UserId <$> (parseJSON j) - parseJSON invalid = typeMismatch "UserId" invalid - -instance FromJSON TenantId where - parseJSON j@(Number _) = TenantId <$> (parseJSON j) - parseJSON invalid = typeMismatch "TenantId" invalid - -instance FromJSON TenantStatus where - parseJSON j@(String _) = tStatus <$> (parseJSON j) - where - tStatus :: Text -> TenantStatus - tStatus "active" = TenantStatusActive - tStatus "inactive" = TenantStatusInActive - tStatus "new" = TenantStatusNew - tStatus _ = error "Unknown status name while parsing TenantStatus field" - parseJSON invalid = typeMismatch "TenantStatus" invalid - -instance FromJSON TenantIncoming where - parseJSON (Object v) = - (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> - v .: "email" <*> - v .: "phone" <*> - (pure ()) <*> - v .: "userId" <*> - v .: "backofficeDomain" - parseJSON invalid = typeMismatch "Unexpected type while paring TenantIncoming" invalid - -instance ToJSON TenantStatus where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tgModify } - where - tgModify :: String -> String - tgModify "TenantStatusActive" = "active" - tgModify "TenantStatusInActive" = "inactive" - tgModify "TenantStatusNew" = "new" - tgModify _ = error "Unknown status name for tenant" +import TH +import qualified Data.HashMap.Strict as HM -instance ToJSON InternalTenant where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).removePrefix } - where - removePrefix = Prelude.drop 11 +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} -instance ToJSON UserId where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a -instance ToJSON TenantId where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions - -instance ToJSON UserStatus where - toJSON x = String $ Data.Text.pack $ show x - -instance ToJSON RoleId where - toJSON (RoleId x) = toJSON x - -instance ToJSON Permission where - toJSON x = toJSON $ show x - -instance (ToJSON a) => ToJSON (Auditable a) where - toJSON Auditable {_data = x} = toJSON x +instance (FromJSON a) => FromJSON (Auditable a) where + parseJSON j = auditable <$> (parseJSON j) diff --git a/SpockOpaleye/src/Lenses.hs b/SpockOpaleye/src/Lenses.hs new file mode 100644 index 0000000..7a4287d --- /dev/null +++ b/SpockOpaleye/src/Lenses.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Lenses where + +import Control.Lens +import Language.Haskell.TH +import UserDefs +import TenantDefs +import RoleDefs +import TH +import Prelude hiding (id) + +$(makeLensesWith abbreviatedFields ''TenantPoly) +$(makeLensesWith abbreviatedFields ''UserPoly) +$(makeLensesWith abbreviatedFields ''RolePoly) +$(makeAuditableLenses ''InternalTenant) +$(makeAuditableLenses ''InternalUser) +$(makeAuditableLenses ''InternalRole) diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs index 5122d02..04d342b 100644 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ b/SpockOpaleye/src/OpaleyeDef.hs @@ -20,122 +20,10 @@ import Opaleye import Control.Lens import Data.Vector -import DataTypes readOnly :: String -> TableProperties () (Column a) readOnly = lmap (const Nothing) . optional -type TenantTableW = TenantPoly - () - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Maybe (Column PGText)) - (Maybe (Column (Nullable PGInt4))) - (Column PGText) - -type TenantTableR = TenantPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column (Nullable PGInt4)) - (Column PGText) - -type UserTableW = UserPoly - () - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Maybe (Column (Nullable PGText))) - (Maybe (Column (Nullable PGText))) - (Maybe (Column PGText)) - -type UserTableR = UserPoly - (Column PGInt4) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Column (Nullable PGText)) - (Column (Nullable PGText)) - (Column PGText) - -type RoleTableW = RolePoly - () - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Maybe (Column PGTimestamptz)) -- createdAt - (Column PGTimestamptz) -- updatedAt - -type RoleTableR = RolePoly - (Column PGInt4) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - (Column PGTimestamptz) -- createdAt - (Column PGTimestamptz) -- updatedAt - -$(makeAdaptorAndInstance "pTenant" ''TenantPoly) - -tenantTable :: Table TenantTableW TenantTableR -tenantTable = Table "tenants" (pTenant - Tenant { - _tenantpolyId = (readOnly "id"), - _tenantpolyCreatedat = (optional "created_at"), - _tenantpolyUpdatedat = (required "updated_at"), - _tenantpolyName = (required "name"), - _tenantpolyFirstname = (required "first_name"), - _tenantpolyLastname = (required "last_name"), - _tenantpolyEmail = (required "email"), - _tenantpolyPhone = (required "phone"), - _tenantpolyStatus = (optional "status"), - _tenantpolyOwnerid = (optional "owner_id"), - _tenantpolyBackofficedomain = (required "backoffice_domain") - } - ) - -$(makeAdaptorAndInstance "pUser" ''UserPoly) - -userTable :: Table UserTableW UserTableR -userTable = Table "users" (pUser - User { - _userpolyId = (readOnly "id") - , _userpolyCreatedat = (optional "created_at") - , _userpolyUpdatedat = (required "updated_at") - , _userpolyTenantid = required "tenant_id" - , _userpolyUsername = required "username" - , _userpolyPassword = required "password" - , _userpolyFirstname = optional "first_name" - , _userpolyLastname = optional "last_name" - , _userpolyStatus = optional "status" - }) - -$(makeAdaptorAndInstance "pRole" ''RolePoly) - -roleTable :: Table RoleTableW RoleTableR -roleTable = Table "roles" (pRole Role { - _rolepolyId = (readOnly "id"), - _rolepolyTenantid = required "tenant_id", - _rolepolyName = required "name", - _rolepolyPermission = required "permissions", - _rolepolyCreatedat = optional "created_at", - _rolepolyUpdatedat = required "updated_at" - }) - userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) @@ -171,146 +59,6 @@ auditTable = Table "audit_logs" (p9 ( , optional "created_at" )) -instance D.Default Constant TenantStatus (Maybe (Column PGText)) where - def = Constant def' - where - def' :: TenantStatus -> (Maybe (Column PGText)) - def' TenantStatusInActive = Just $ pgStrictText "inactive" - def' TenantStatusActive = Just $ pgStrictText "active" - def' TenantStatusNew = Just $ pgStrictText "new" - -instance FromField TenantStatus where - fromField _ mdata = return tStatus - where - tStatus = - case mdata of - Just "active" -> TenantStatusActive - Just "inactive" -> TenantStatusInActive - Just "new" -> TenantStatusNew - _ -> error "Bad value read for user status" - -instance QueryRunnerColumnDefault PGText TenantStatus where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant UserStatus (Maybe (Column PGText)) where - def = Constant def' - where - def' :: UserStatus -> Maybe (Column PGText) - def' UserStatusInActive = Just $ pgStrictText "inactive" - def' UserStatusActive = Just $ pgStrictText "active" - def' UserStatusBlocked = Just $ pgStrictText "blocked" - -instance FromField (UserStatus) where - fromField _ mdata = return gender - where - gender = - case mdata of - Just "active" -> UserStatusActive - Just "inactive" -> UserStatusInActive - Just "blocked" -> UserStatusBlocked - _ -> error "Bad value read for user status" - -instance QueryRunnerColumnDefault PGText UserStatus where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant (NonEmpty Permission) (Column (PGArray PGText)) where - def = Constant def' - where - def' :: (NonEmpty Permission) -> (Column (PGArray PGText)) - def' (ph :| pl) = pgArray pgStrictText $ toText <$> (ph : pl) - where - toText :: Permission -> Text - toText Read = "Read" - toText Create = "Create" - toText Update = "Update" - toText Delete = "Delete" - -instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance FromField Permission where - fromField _ mdata = return $ makePermission mdata - where - makePermission (Just x) = toPermission $ decodeUtf8 x - makePermission Nothing = error "No data read from db" - -toPermission :: Text -> Permission -toPermission "Read" = Read -toPermission "Create" = Create -toPermission "Update" = Update -toPermission "Delete" = Delete -toPermission _ = error "Unrecognized permission" - -instance FromField [Permission] where - fromField f mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField f mdata - -instance FromField (NonEmpty Permission) where - fromField f mdata = (fromJust.nonEmpty) <$> (fromField f mdata) - -instance QueryRunnerColumnDefault PGText Permission where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant (UserId) (Column PGInt4) where - def = Constant def' - where - def' :: UserId -> (Column PGInt4) - def' (UserId id') = pgInt4 id' - -instance D.Default Constant UserId () where - def = Constant (\_ -> ()) - -instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where - def = Constant def' - where - def' :: UserId -> (Column (Nullable PGInt4)) - def' (UserId id') = (toNullable.pgInt4) id' - -instance FromField UserId where - fromField f mdata = do - x <- fromField f mdata - return $ UserId x - -instance QueryRunnerColumnDefault PGInt4 UserId where - queryRunnerColumnDefault = fieldQueryRunnerColumn - --- -instance D.Default Constant RoleId (Column PGInt4) where - def = Constant def' - where - def' :: RoleId -> (Column PGInt4) - def' (RoleId id') = pgInt4 id' - -instance D.Default Constant RoleId () where - def = Constant (\_ -> ()) - -instance FromField RoleId where - fromField f mdata = do - x <- fromField f mdata - return $ RoleId x - -instance QueryRunnerColumnDefault PGInt4 RoleId where - queryRunnerColumnDefault = fieldQueryRunnerColumn - --- -instance D.Default Constant TenantId (Column PGInt4) where - def = Constant def' - where - def' :: TenantId -> (Column PGInt4) - def' (TenantId id') = pgInt4 id' - -instance D.Default Constant TenantId () where - def = Constant (\_ -> ()) - -instance FromField TenantId where - fromField f mdata = do - x <- fromField f mdata - return $ TenantId x - -instance QueryRunnerColumnDefault PGInt4 TenantId where - queryRunnerColumnDefault = fieldQueryRunnerColumn - --- - instance D.Default Constant () (Maybe (Column PGInt4)) where def = Constant (\_ -> Nothing) diff --git a/SpockOpaleye/src/Role/RoleDefs.hs b/SpockOpaleye/src/Role/RoleDefs.hs new file mode 100644 index 0000000..42a8b6e --- /dev/null +++ b/SpockOpaleye/src/Role/RoleDefs.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module RoleDefs where + +import Database.PostgreSQL.Simple.FromField +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import OpaleyeDef +import TenantId +import Data.Text +import Data.Maybe +import Data.List.NonEmpty +import Data.Time (UTCTime) +import Data.Aeson +import Data.Vector +import Data.Aeson.Types +import Data.Text.Encoding +import TH + +newtype RoleId = RoleId Int + deriving (Show) + +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) + +$(makeAdaptorAndInstance "pRole" ''RolePoly) + +type InternalRole = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +type Role = Auditable InternalRole +type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () + +type RoleTableW = RolePoly + () + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + +type RoleTableR = RolePoly + (Column PGInt4) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + +roleTable :: Table RoleTableW RoleTableR +roleTable = Table "roles" (pRole Role { + _rolepolyId = (readOnly "id"), + _rolepolyTenantid = required "tenant_id", + _rolepolyName = required "name", + _rolepolyPermission = required "permissions", + _rolepolyCreatedat = optional "created_at", + _rolepolyUpdatedat = required "updated_at" + }) + +instance D.Default Constant RoleId (Column PGInt4) where + def = Constant def' + where + def' :: RoleId -> (Column PGInt4) + def' (RoleId id') = pgInt4 id' + +instance D.Default Constant RoleId () where + def = Constant (\_ -> ()) + +instance FromField RoleId where + fromField f mdata = do + x <- fromField f mdata + return $ RoleId x + +instance QueryRunnerColumnDefault PGInt4 RoleId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance D.Default Constant (NonEmpty Permission) (Column (PGArray PGText)) where + def = Constant def' + where + def' :: (NonEmpty Permission) -> (Column (PGArray PGText)) + def' (ph :| pl) = pgArray pgStrictText $ toText <$> (ph : pl) + where + toText :: Permission -> Text + toText Read = "Read" + toText Create = "Create" + toText Update = "Update" + toText Delete = "Delete" + +instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromField Permission where + fromField _ mdata = return $ makePermission mdata + where + makePermission (Just x) = toPermission $ decodeUtf8 x + makePermission Nothing = error "No data read from db" + +toPermission :: Text -> Permission +toPermission "Read" = Read +toPermission "Create" = Create +toPermission "Update" = Update +toPermission "Delete" = Delete +toPermission _ = error "Unrecognized permission" + +instance FromField [Permission] where + fromField f mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField f mdata + +instance FromField (NonEmpty Permission) where + fromField f mdata = (fromJust.nonEmpty) <$> (fromField f mdata) + +instance QueryRunnerColumnDefault PGText Permission where + queryRunnerColumnDefault = fieldQueryRunnerColumn +-- + +data Permission = Read | Create | Update | Delete + deriving (Show) + +instance ToJSON RoleId where + toJSON (RoleId x) = toJSON x + +instance ToJSON Permission where + toJSON x = toJSON $ show x + +instance (ToJSON a) => ToJSON (Auditable a) where + toJSON Auditable {_data = x} = toJSON x diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 567f144..c8d603d 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -16,10 +16,23 @@ import DataTypes import GHC.Int import Opaleye import OpaleyeDef +import RoleDefs import ApiBase import Control.Lens import Prelude hiding (id) +import TenantId +import TH +import Lenses +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM + +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a createRole :: RoleIncoming -> AppM Role createRole role = auditable <$> createRow roleTable role diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/TH.hs index efb8158..7078974 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/TH.hs @@ -7,12 +7,13 @@ import Control.Lens import Language.Haskell.TH import Data.Char import Data.List (elemIndex) -import DataTypes import qualified Data.HashMap.Strict as HM import Data.Text (pack) import Data.Aeson (Value(..), ToJSON(..)) +data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) + getTypeSegs :: Type -> [Type] getTypeSegs a@(ConT _) = [a] getTypeSegs (AppT a b) = (b : getTypeSegs a) @@ -105,7 +106,7 @@ mkInstanceFunction :: String -> Q Exp mkInstanceFunction nam = do Just _field_name <- lookupValueName nam -- TODO remove dependency on "DataTypes" module name or don't hard code it in. - fn <- lookupValueName $ "DataTypes." ++ (transformName nam) + fn <- lookupValueName $ "Lenses." ++ (transformName nam) case fn of Just field_name -> do [| lens ($(return $ VarE _field_name)._data) (\r v -> r { diff --git a/SpockOpaleye/src/Tenant/TenantDefs.hs b/SpockOpaleye/src/Tenant/TenantDefs.hs new file mode 100644 index 0000000..33067a1 --- /dev/null +++ b/SpockOpaleye/src/Tenant/TenantDefs.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module TenantDefs where + +import Database.PostgreSQL.Simple.FromField hiding (name) +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import OpaleyeDef +import GHC.Generics +import Data.Time +import Data.Text +import UserId +import TenantId +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import TH +import Prelude hiding(id) +import qualified Data.HashMap.Strict as HM + +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a + +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) + + +data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew + deriving (Show, Generic) + +type InternalTenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text + +type Tenant = Auditable InternalTenant + +type TenantTableW = TenantPoly + () + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Maybe (Column PGText)) + (Maybe (Column (Nullable PGInt4))) + (Column PGText) + +type TenantTableR = TenantPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column (Nullable PGInt4)) + (Column PGText) + +$(makeAdaptorAndInstance "pTenant" ''TenantPoly) + +tenantTable :: Table TenantTableW TenantTableR +tenantTable = Table "tenants" (pTenant + Tenant { + _tenantpolyId = (readOnly "id"), + _tenantpolyCreatedat = (optional "created_at"), + _tenantpolyUpdatedat = (required "updated_at"), + _tenantpolyName = (required "name"), + _tenantpolyFirstname = (required "first_name"), + _tenantpolyLastname = (required "last_name"), + _tenantpolyEmail = (required "email"), + _tenantpolyPhone = (required "phone"), + _tenantpolyStatus = (optional "status"), + _tenantpolyOwnerid = (optional "owner_id"), + _tenantpolyBackofficedomain = (required "backoffice_domain") + } + ) + +getTestTenant :: Tenant +getTestTenant = auditable $ Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +type TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text + +instance D.Default Constant TenantStatus (Maybe (Column PGText)) where + def = Constant def' + where + def' :: TenantStatus -> (Maybe (Column PGText)) + def' TenantStatusInActive = Just $ pgStrictText "inactive" + def' TenantStatusActive = Just $ pgStrictText "active" + def' TenantStatusNew = Just $ pgStrictText "new" + +instance FromField TenantStatus where + fromField _ mdata = return tStatus + where + tStatus = + case mdata of + Just "active" -> TenantStatusActive + Just "inactive" -> TenantStatusInActive + Just "new" -> TenantStatusNew + _ -> error "Bad value read for user status" + +instance QueryRunnerColumnDefault PGText TenantStatus where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON TenantStatus where + parseJSON j@(String _) = tStatus <$> (parseJSON j) + where + tStatus :: Text -> TenantStatus + tStatus "active" = TenantStatusActive + tStatus "inactive" = TenantStatusInActive + tStatus "new" = TenantStatusNew + tStatus _ = error "Unknown status name while parsing TenantStatus field" + parseJSON invalid = typeMismatch "TenantStatus" invalid + +instance FromJSON TenantIncoming where + parseJSON (Object v) = + (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> + v .: "email" <*> + v .: "phone" <*> + (pure ()) <*> + v .: "userId" <*> + v .: "backofficeDomain" + parseJSON invalid = typeMismatch "Unexpected type while paring TenantIncoming" invalid + +instance ToJSON TenantStatus where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tgModify } + where + tgModify :: String -> String + tgModify "TenantStatusActive" = "active" + tgModify "TenantStatusInActive" = "inactive" + tgModify "TenantStatusNew" = "new" + tgModify _ = error "Unknown status name for tenant" + +instance ToJSON InternalTenant where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).removePrefix } + where + removePrefix = Prelude.drop 11 + diff --git a/SpockOpaleye/src/Tenant/TenantId.hs b/SpockOpaleye/src/Tenant/TenantId.hs new file mode 100644 index 0000000..cb63d13 --- /dev/null +++ b/SpockOpaleye/src/Tenant/TenantId.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module TenantId where + +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Database.PostgreSQL.Simple.FromField +import Data.Aeson +import Data.Aeson.Types +import GHC.Generics + +newtype TenantId = TenantId Int + deriving (Show, Generic) + +instance D.Default Constant TenantId (Column PGInt4) where + def = Constant def' + where + def' :: TenantId -> (Column PGInt4) + def' (TenantId id') = pgInt4 id' + +instance D.Default Constant TenantId () where + def = Constant (\_ -> ()) + +instance FromField TenantId where + fromField f mdata = do + x <- fromField f mdata + return $ TenantId x + +instance QueryRunnerColumnDefault PGInt4 TenantId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON TenantId where + parseJSON j@(Number _) = TenantId <$> (parseJSON j) + parseJSON invalid = typeMismatch "TenantId" invalid + +instance ToJSON TenantId where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index ee92cd4..2ceef70 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -28,6 +28,10 @@ import OpaleyeDef import Prelude hiding (id) import RoleApi import UserApi +import TH +import Lenses +import TenantDefs +import TenantId createTenant :: TenantIncoming -> AppM Tenant createTenant tenant = do diff --git a/SpockOpaleye/src/User/UserDefs.hs b/SpockOpaleye/src/User/UserDefs.hs new file mode 100644 index 0000000..b435127 --- /dev/null +++ b/SpockOpaleye/src/User/UserDefs.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module UserDefs where + +import Database.PostgreSQL.Simple.FromField +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import Data.Time +import OpaleyeDef +import GHC.Generics +import Data.Text +import CryptoDef +import TenantId +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM +import TH +import Data.Char +import Prelude hiding (id) +import UserId + +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a + +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 +} deriving (Show) + +type UserTableW = UserPoly + () + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Maybe (Column (Nullable PGText))) + (Maybe (Column (Nullable PGText))) + (Maybe (Column PGText)) + +type UserTableR = UserPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Column (Nullable PGText)) + (Column (Nullable PGText)) + (Column PGText) + + +$(makeAdaptorAndInstance "pUser" ''UserPoly) + +userTable :: Table UserTableW UserTableR +userTable = Table "users" (pUser + User { + _userpolyId = (readOnly "id") + , _userpolyCreatedat = (optional "created_at") + , _userpolyUpdatedat = (required "updated_at") + , _userpolyTenantid = required "tenant_id" + , _userpolyUsername = required "username" + , _userpolyPassword = required "password" + , _userpolyFirstname = optional "first_name" + , _userpolyLastname = optional "last_name" + , _userpolyStatus = optional "status" + }) + +data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked + deriving (Show) + +type InternalUser = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus +type User = Auditable InternalUser + +getTestUser :: IO User +getTestUser = do + Just password_ <- bcryptPassword "adsasda" + return $ auditable $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) () + +instance D.Default Constant UserStatus (Maybe (Column PGText)) where + def = Constant def' + where + def' :: UserStatus -> Maybe (Column PGText) + def' UserStatusInActive = Just $ pgStrictText "inactive" + def' UserStatusActive = Just $ pgStrictText "active" + def' UserStatusBlocked = Just $ pgStrictText "blocked" + +instance FromField (UserStatus) where + fromField _ mdata = return gender + where + gender = + case mdata of + Just "active" -> UserStatusActive + Just "inactive" -> UserStatusInActive + Just "blocked" -> UserStatusBlocked + _ -> error "Bad value read for user status" + +instance QueryRunnerColumnDefault PGText UserStatus where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance ToJSON UserStatus where + toJSON x = String $ Data.Text.pack $ show x diff --git a/SpockOpaleye/src/User/UserId.hs b/SpockOpaleye/src/User/UserId.hs new file mode 100644 index 0000000..6db8f57 --- /dev/null +++ b/SpockOpaleye/src/User/UserId.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module UserId where + +import Database.PostgreSQL.Simple.FromField +import Opaleye +import qualified Data.Profunctor.Product.Default as D +import GHC.Generics + +import Data.Aeson +import Data.Aeson.Types + +newtype UserId = UserId Int + deriving (Show, Generic) + +instance D.Default Constant (UserId) (Column PGInt4) where + def = Constant def' + where + def' :: UserId -> (Column PGInt4) + def' (UserId id') = pgInt4 id' + +instance D.Default Constant UserId () where + def = Constant (\_ -> ()) + +instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where + def = Constant def' + where + def' :: UserId -> (Column (Nullable PGInt4)) + def' (UserId id') = (toNullable.pgInt4) id' + +instance FromField UserId where + fromField f mdata = do + x <- fromField f mdata + return $ UserId x + +instance QueryRunnerColumnDefault PGInt4 UserId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON UserId where + parseJSON j@(Number _) = UserId <$> (parseJSON j) + parseJSON invalid = typeMismatch "UserId" invalid + +instance ToJSON UserId where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 39e1d45..a223f09 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -29,6 +29,13 @@ import OpaleyeDef import CryptoDef import Prelude hiding (id) +import RoleDefs +import UserDefs +import UserId +import TenantId + +import TH +import Lenses createUser :: UserIncoming -> AppM User createUser user = do diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs index 3febd95..07cfb31 100644 --- a/SpockOpaleye/src/UserServices.hs +++ b/SpockOpaleye/src/UserServices.hs @@ -11,6 +11,7 @@ import Data.Monoid import Control.Monad.IO.Class import Validations import TenantApi +import TenantDefs doCreateTenant :: TenantIncoming -> AppM (Either T.Text Tenant) doCreateTenant incomingTenant = do diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 3012b7b..4eb026a 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -12,6 +12,8 @@ import Control.Lens import qualified Data.Text as T import DataTypes import TenantApi +import TenantDefs +import Lenses validateIncomingTenant :: TenantIncoming -> AppM ValidationResult validateIncomingTenant tenant = do diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index d2e1ea3..904eace 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -73,3 +73,5 @@ extra-lib-dirs: [] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor +ghc-options: + SpockOpaleye: -ddump-splices From caa39c09d927cbb4d7b010cd4b2b48bd2411eb30 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 16 Dec 2016 10:52:51 +0000 Subject: [PATCH 66/69] Rename files --- SpockOpaleye/SpockOpaleye.cabal | 3 ++- SpockOpaleye/src/ApiBase.hs | 2 +- SpockOpaleye/src/Auditable.hs | 5 ++++ SpockOpaleye/src/{TH.hs => AuditableTH.hs} | 5 ++-- SpockOpaleye/src/DataTypes.hs | 30 +++------------------- SpockOpaleye/src/JsonInstances.hs | 2 +- SpockOpaleye/src/Lenses.hs | 2 +- SpockOpaleye/src/Role/RoleDefs.hs | 2 +- SpockOpaleye/src/RoleAPi.hs | 2 +- SpockOpaleye/src/Tenant/TenantDefs.hs | 2 +- SpockOpaleye/src/TenantApi.hs | 2 +- SpockOpaleye/src/User/UserDefs.hs | 2 +- SpockOpaleye/src/UserApi.hs | 2 +- SpockOpaleye/src/Validations.hs | 3 +++ 14 files changed, 24 insertions(+), 40 deletions(-) create mode 100644 SpockOpaleye/src/Auditable.hs rename SpockOpaleye/src/{TH.hs => AuditableTH.hs} (97%) diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 534b683..d8c44ab 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -36,7 +36,8 @@ library Conf, UserServices, Email, - TH + AuditableTH, + Auditable build-depends: base >= 4.7 && < 5 ,smtp-mail ,lifted-base diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/src/ApiBase.hs index b4a8ffc..66052a6 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/src/ApiBase.hs @@ -20,7 +20,7 @@ import OpaleyeDef import qualified Data.Text as T import GHC.Int import Prelude hiding (id) -import TH +import Auditable import Data.Aeson (Value(..)) import Data.ByteString (ByteString) import JsonInstances () diff --git a/SpockOpaleye/src/Auditable.hs b/SpockOpaleye/src/Auditable.hs new file mode 100644 index 0000000..e7efa01 --- /dev/null +++ b/SpockOpaleye/src/Auditable.hs @@ -0,0 +1,5 @@ +module Auditable where + +import Data.Aeson.Types + +data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) diff --git a/SpockOpaleye/src/TH.hs b/SpockOpaleye/src/AuditableTH.hs similarity index 97% rename from SpockOpaleye/src/TH.hs rename to SpockOpaleye/src/AuditableTH.hs index 7078974..a497f7d 100644 --- a/SpockOpaleye/src/TH.hs +++ b/SpockOpaleye/src/AuditableTH.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module TH where +module AuditableTH where import Control.Lens import Language.Haskell.TH @@ -9,11 +9,10 @@ import Data.Char import Data.List (elemIndex) import qualified Data.HashMap.Strict as HM import Data.Text (pack) +import Auditable import Data.Aeson (Value(..), ToJSON(..)) -data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) - getTypeSegs :: Type -> [Type] getTypeSegs a@(ConT _) = [a] getTypeSegs (AppT a b) = (b : getTypeSegs a) diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs index 3c33891..d61ba61 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/src/DataTypes.hs @@ -1,36 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} - module DataTypes where -import Control.Lens -import qualified Control.Monad.Reader as R import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer -import Data.List.NonEmpty -import Data.Text -import Data.Time (UTCTime) -import Database.PostgreSQL.Simple -import GHC.Generics -import Data.Aeson (Value(..)) import Data.ByteString - -import Control.Exception -import Control.Monad.Trans.Except -import Data.Time import TenantDefs import UserDefs -import TH - -data ValidationResult = Valid | Invalid String - deriving (Eq, Show) - - +import Control.Exception +import Database.PostgreSQL.Simple +import Control.Monad.Trans.Except type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index fbb7169..84bbc63 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -10,7 +10,7 @@ import Data.Char import Data.Text import DataTypes -import TH +import Auditable import qualified Data.HashMap.Strict as HM auditable :: a -> Auditable a diff --git a/SpockOpaleye/src/Lenses.hs b/SpockOpaleye/src/Lenses.hs index 7a4287d..c236ee3 100644 --- a/SpockOpaleye/src/Lenses.hs +++ b/SpockOpaleye/src/Lenses.hs @@ -11,7 +11,7 @@ import Language.Haskell.TH import UserDefs import TenantDefs import RoleDefs -import TH +import AuditableTH import Prelude hiding (id) $(makeLensesWith abbreviatedFields ''TenantPoly) diff --git a/SpockOpaleye/src/Role/RoleDefs.hs b/SpockOpaleye/src/Role/RoleDefs.hs index 42a8b6e..6a5b420 100644 --- a/SpockOpaleye/src/Role/RoleDefs.hs +++ b/SpockOpaleye/src/Role/RoleDefs.hs @@ -22,7 +22,7 @@ import Data.Aeson import Data.Vector import Data.Aeson.Types import Data.Text.Encoding -import TH +import Auditable newtype RoleId = RoleId Int deriving (Show) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index c8d603d..511ee9e 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -22,7 +22,7 @@ import ApiBase import Control.Lens import Prelude hiding (id) import TenantId -import TH +import Auditable import Lenses import Data.Aeson import Data.Aeson.Types diff --git a/SpockOpaleye/src/Tenant/TenantDefs.hs b/SpockOpaleye/src/Tenant/TenantDefs.hs index 33067a1..aedaab0 100644 --- a/SpockOpaleye/src/Tenant/TenantDefs.hs +++ b/SpockOpaleye/src/Tenant/TenantDefs.hs @@ -22,7 +22,7 @@ import TenantId import Data.Aeson import Data.Aeson.Types import Data.Char -import TH +import Auditable import Prelude hiding(id) import qualified Data.HashMap.Strict as HM diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 2ceef70..624b513 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -28,7 +28,7 @@ import OpaleyeDef import Prelude hiding (id) import RoleApi import UserApi -import TH +import Auditable import Lenses import TenantDefs import TenantId diff --git a/SpockOpaleye/src/User/UserDefs.hs b/SpockOpaleye/src/User/UserDefs.hs index b435127..01189af 100644 --- a/SpockOpaleye/src/User/UserDefs.hs +++ b/SpockOpaleye/src/User/UserDefs.hs @@ -22,7 +22,7 @@ import TenantId import Data.Aeson import Data.Aeson.Types import qualified Data.HashMap.Strict as HM -import TH +import Auditable import Data.Char import Prelude hiding (id) import UserId diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index a223f09..9d471da 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -34,7 +34,7 @@ import UserDefs import UserId import TenantId -import TH +import Auditable import Lenses createUser :: UserIncoming -> AppM User diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 4eb026a..abfcd7f 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -15,6 +15,9 @@ import TenantApi import TenantDefs import Lenses +data ValidationResult = Valid | Invalid String + deriving (Eq, Show) + validateIncomingTenant :: TenantIncoming -> AppM ValidationResult validateIncomingTenant tenant = do unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain) From 117f8db6995fd56c8606e7e7538a57f681517be8 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 16 Dec 2016 15:46:41 +0000 Subject: [PATCH 67/69] Moved code to a separate package AppCore --- SpockOpaleye/SpockOpaleye.cabal | 21 ++---- SpockOpaleye/app/Main.hs | 15 +---- SpockOpaleye/appcore/LICENSE | 30 +++++++++ SpockOpaleye/appcore/Setup.hs | 2 + SpockOpaleye/appcore/app/Main.hs | 6 ++ SpockOpaleye/appcore/appcore.cabal | 67 +++++++++++++++++++ SpockOpaleye/{ => appcore}/src/ApiBase.hs | 31 ++------- SpockOpaleye/appcore/src/AppCore.hs | 32 +++++++++ .../{src/DataTypes.hs => appcore/src/AppM.hs} | 22 +++++- SpockOpaleye/{ => appcore}/src/Auditable.hs | 0 SpockOpaleye/{ => appcore}/src/AuditableTH.hs | 0 SpockOpaleye/{ => appcore}/src/CryptoDef.hs | 0 SpockOpaleye/{ => appcore}/src/Lenses.hs | 0 SpockOpaleye/{ => appcore}/src/OpaleyeDef.hs | 0 SpockOpaleye/appcore/src/Role/RoleApi.hs | 13 ++++ .../{ => appcore}/src/Role/RoleDefs.hs | 0 SpockOpaleye/appcore/src/Tenant/TenantApi.hs | 22 ++++++ .../{ => appcore}/src/Tenant/TenantDefs.hs | 7 +- .../{ => appcore}/src/Tenant/TenantId.hs | 0 SpockOpaleye/appcore/src/User/UserApi.hs | 24 +++++++ .../{ => appcore}/src/User/UserDefs.hs | 7 +- SpockOpaleye/{ => appcore}/src/User/UserId.hs | 0 SpockOpaleye/appcore/src/Utils.hs | 12 ++++ SpockOpaleye/appcore/stack.yaml | 66 ++++++++++++++++++ SpockOpaleye/appcore/test/Spec.hs | 2 + SpockOpaleye/src/Email.hs | 5 +- SpockOpaleye/src/JsonInstances.hs | 9 +-- SpockOpaleye/src/RoleAPi.hs | 36 +++------- SpockOpaleye/src/TenantApi.hs | 16 +---- SpockOpaleye/src/UserApi.hs | 23 +------ SpockOpaleye/src/UserServices.hs | 4 +- SpockOpaleye/src/Validations.hs | 4 +- SpockOpaleye/stack.yaml | 1 + 33 files changed, 329 insertions(+), 148 deletions(-) create mode 100644 SpockOpaleye/appcore/LICENSE create mode 100644 SpockOpaleye/appcore/Setup.hs create mode 100644 SpockOpaleye/appcore/app/Main.hs create mode 100644 SpockOpaleye/appcore/appcore.cabal rename SpockOpaleye/{ => appcore}/src/ApiBase.hs (93%) create mode 100644 SpockOpaleye/appcore/src/AppCore.hs rename SpockOpaleye/{src/DataTypes.hs => appcore/src/AppM.hs} (50%) rename SpockOpaleye/{ => appcore}/src/Auditable.hs (100%) rename SpockOpaleye/{ => appcore}/src/AuditableTH.hs (100%) rename SpockOpaleye/{ => appcore}/src/CryptoDef.hs (100%) rename SpockOpaleye/{ => appcore}/src/Lenses.hs (100%) rename SpockOpaleye/{ => appcore}/src/OpaleyeDef.hs (100%) create mode 100644 SpockOpaleye/appcore/src/Role/RoleApi.hs rename SpockOpaleye/{ => appcore}/src/Role/RoleDefs.hs (100%) create mode 100644 SpockOpaleye/appcore/src/Tenant/TenantApi.hs rename SpockOpaleye/{ => appcore}/src/Tenant/TenantDefs.hs (96%) rename SpockOpaleye/{ => appcore}/src/Tenant/TenantId.hs (100%) create mode 100644 SpockOpaleye/appcore/src/User/UserApi.hs rename SpockOpaleye/{ => appcore}/src/User/UserDefs.hs (95%) rename SpockOpaleye/{ => appcore}/src/User/UserId.hs (100%) create mode 100644 SpockOpaleye/appcore/src/Utils.hs create mode 100644 SpockOpaleye/appcore/stack.yaml create mode 100644 SpockOpaleye/appcore/test/Spec.hs diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index d8c44ab..c701a74 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -15,30 +15,16 @@ cabal-version: >=1.10 library hs-source-dirs: src - ,src/Role - ,src/Tenant - ,src/User - exposed-modules: DataTypes, - UserDefs, - TenantDefs, - RoleDefs, - TenantId, - UserId, - Lenses, - ApiBase, - TenantApi, + exposed-modules: TenantApi, UserApi, RoleApi, - OpaleyeDef, - CryptoDef, JsonInstances, Validations, Conf, UserServices, - Email, - AuditableTH, - Auditable + Email build-depends: base >= 4.7 && < 5 + ,appcore ,smtp-mail ,lifted-base ,airbrake @@ -75,6 +61,7 @@ executable SpockOpaleye-exe , postgresql-simple , airbrake , bytestring + , appcore , here , mime-mail , filepath diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 2594afe..50b89c7 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -4,8 +4,8 @@ {-# LANGUAGE TemplateHaskell #-} module Main where +import AppCore import Database.PostgreSQL.Simple -import DataTypes import JsonInstances () import TenantApi import Validations @@ -17,7 +17,6 @@ import Web.Spock.Config import Control.Monad.Reader import Control.Monad.Writer import qualified Control.Monad.Reader as R -import CryptoDef import qualified Data.Text as T import Data.Time import Prelude hiding (id) @@ -27,8 +26,6 @@ import Control.Exception.Lifted import Airbrake import Airbrake.WebRequest import Data.ByteString (ByteString) -import TenantDefs -import UserDefs data MySession = EmptySession @@ -38,16 +35,6 @@ data MyAppState = DummyAppState data AppResult a = AppOk a | AppErr T.Text -getCurrentUser :: AppM (Maybe User) -getCurrentUser = do - (_, _, user) <- R.ask - return user - - -getCurrentTenant :: AppM (Maybe Tenant) -getCurrentTenant = do - (_, tenant, _) <- R.ask - return tenant connectDb :: IO Connection connectDb = connect defaultConnectInfo { connectDatabase = "haskell-webapps" } diff --git a/SpockOpaleye/appcore/LICENSE b/SpockOpaleye/appcore/LICENSE new file mode 100644 index 0000000..fc03544 --- /dev/null +++ b/SpockOpaleye/appcore/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/SpockOpaleye/appcore/Setup.hs b/SpockOpaleye/appcore/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/SpockOpaleye/appcore/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SpockOpaleye/appcore/app/Main.hs b/SpockOpaleye/appcore/app/Main.hs new file mode 100644 index 0000000..de1c1ab --- /dev/null +++ b/SpockOpaleye/appcore/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/SpockOpaleye/appcore/appcore.cabal b/SpockOpaleye/appcore/appcore.cabal new file mode 100644 index 0000000..dd2a135 --- /dev/null +++ b/SpockOpaleye/appcore/appcore.cabal @@ -0,0 +1,67 @@ +name: appcore +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/githubuser/appcore#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2016 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + ,src/User + ,src/Role + ,src/Tenant + exposed-modules: AppCore + other-modules: Auditable + ,AuditableTH + ,CryptoDef + ,OpaleyeDef + ,UserDefs + ,TenantDefs + ,RoleDefs + ,Lenses + ,UserId + ,TenantId + ,Utils + ,AppM + ,ApiBase + ,UserApi + ,TenantApi + build-depends: base >= 4.7 && < 5 + , aeson + , transformers + , text + , lens + , time + , old-time + , product-profunctors + , profunctors + , vector + , bytestring + , opaleye + , postgresql-simple + , template-haskell + , unordered-containers + , bcrypt + , mtl + default-language: Haskell2010 + +test-suite appcore-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , appcore + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/githubuser/appcore diff --git a/SpockOpaleye/src/ApiBase.hs b/SpockOpaleye/appcore/src/ApiBase.hs similarity index 93% rename from SpockOpaleye/src/ApiBase.hs rename to SpockOpaleye/appcore/src/ApiBase.hs index 66052a6..6174916 100644 --- a/SpockOpaleye/src/ApiBase.hs +++ b/SpockOpaleye/appcore/src/ApiBase.hs @@ -7,6 +7,12 @@ module ApiBase where +import AppM +import UserDefs +import TenantDefs +import OpaleyeDef +import Lenses +import Auditable import Control.Lens import Control.Monad.IO.Class import Control.Monad.Reader @@ -14,38 +20,13 @@ import qualified Control.Monad.Reader as R import Control.Monad.Writer import qualified Data.Profunctor.Product.Default as D import Data.Time (UTCTime, getCurrentTime) -import DataTypes import Opaleye -import OpaleyeDef import qualified Data.Text as T import GHC.Int import Prelude hiding (id) -import Auditable import Data.Aeson (Value(..)) import Data.ByteString (ByteString) -import JsonInstances () -import DataTypes -import Lenses import Database.PostgreSQL.Simple -import UserDefs -import TenantDefs - -getConnection :: AppM Connection -getConnection = do - (conn, _, _) <- R.ask - return conn - -getCurrentUser :: AppM (Maybe User) -getCurrentUser = do - (_, _, user) <- R.ask - return user - - -getCurrentTenant :: AppM (Maybe Tenant) -getCurrentTenant = do - (_, tenant, _) <- R.ask - return tenant - removeRawDbRows :: Table columnsW columnsR -> (columnsR -> Column PGBool) -> AppM GHC.Int.Int64 removeRawDbRows table matchFunc = do diff --git a/SpockOpaleye/appcore/src/AppCore.hs b/SpockOpaleye/appcore/src/AppCore.hs new file mode 100644 index 0000000..3464222 --- /dev/null +++ b/SpockOpaleye/appcore/src/AppCore.hs @@ -0,0 +1,32 @@ +module AppCore ( + module UserDefs + ,module UserId + ,module TenantDefs + ,module TenantId + ,module RoleDefs + ,module Lenses + ,module CryptoDef + ,Auditable + ,module ApiBase + ,module OpaleyeDef + ,module UserApi + ,module TenantApi + ,AppM + ,auditable + ,wrapAuditable +) where + +import UserDefs +import RoleDefs +import TenantDefs +import TenantId +import UserId +import Lenses +import CryptoDef +import Auditable +import OpaleyeDef +import Utils +import ApiBase +import UserApi +import TenantApi +import AppM diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/appcore/src/AppM.hs similarity index 50% rename from SpockOpaleye/src/DataTypes.hs rename to SpockOpaleye/appcore/src/AppM.hs index d61ba61..a1ab7d2 100644 --- a/SpockOpaleye/src/DataTypes.hs +++ b/SpockOpaleye/appcore/src/AppM.hs @@ -1,12 +1,28 @@ -module DataTypes where +module AppM where +import UserDefs +import TenantDefs +import qualified Control.Monad.Reader as R import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Data.ByteString -import TenantDefs -import UserDefs import Control.Exception import Database.PostgreSQL.Simple import Control.Monad.Trans.Except type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a + +getCurrentUser :: AppM (Maybe User) +getCurrentUser = do + (_, _, user) <- R.ask + return user + +getCurrentTenant :: AppM (Maybe Tenant) +getCurrentTenant = do + (_, tenant, _) <- R.ask + return tenant + +getConnection :: AppM Connection +getConnection = do + (conn, tenant, _) <- R.ask + return conn diff --git a/SpockOpaleye/src/Auditable.hs b/SpockOpaleye/appcore/src/Auditable.hs similarity index 100% rename from SpockOpaleye/src/Auditable.hs rename to SpockOpaleye/appcore/src/Auditable.hs diff --git a/SpockOpaleye/src/AuditableTH.hs b/SpockOpaleye/appcore/src/AuditableTH.hs similarity index 100% rename from SpockOpaleye/src/AuditableTH.hs rename to SpockOpaleye/appcore/src/AuditableTH.hs diff --git a/SpockOpaleye/src/CryptoDef.hs b/SpockOpaleye/appcore/src/CryptoDef.hs similarity index 100% rename from SpockOpaleye/src/CryptoDef.hs rename to SpockOpaleye/appcore/src/CryptoDef.hs diff --git a/SpockOpaleye/src/Lenses.hs b/SpockOpaleye/appcore/src/Lenses.hs similarity index 100% rename from SpockOpaleye/src/Lenses.hs rename to SpockOpaleye/appcore/src/Lenses.hs diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/appcore/src/OpaleyeDef.hs similarity index 100% rename from SpockOpaleye/src/OpaleyeDef.hs rename to SpockOpaleye/appcore/src/OpaleyeDef.hs diff --git a/SpockOpaleye/appcore/src/Role/RoleApi.hs b/SpockOpaleye/appcore/src/Role/RoleApi.hs new file mode 100644 index 0000000..15a1640 --- /dev/null +++ b/SpockOpaleye/appcore/src/Role/RoleApi.hs @@ -0,0 +1,13 @@ +module RoleApi where + +import Control.Monad.IO.Class +import Control.Lens +import UserDefs +import ApiBase +import AppM +import Utils +import Lenses + +createRole :: RoleIncoming -> AppM Role +createRole role = auditable <$> createRow roleTable role + diff --git a/SpockOpaleye/src/Role/RoleDefs.hs b/SpockOpaleye/appcore/src/Role/RoleDefs.hs similarity index 100% rename from SpockOpaleye/src/Role/RoleDefs.hs rename to SpockOpaleye/appcore/src/Role/RoleDefs.hs diff --git a/SpockOpaleye/appcore/src/Tenant/TenantApi.hs b/SpockOpaleye/appcore/src/Tenant/TenantApi.hs new file mode 100644 index 0000000..74aae4d --- /dev/null +++ b/SpockOpaleye/appcore/src/Tenant/TenantApi.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module TenantApi where + +import Control.Monad.IO.Class +import Control.Lens +import TenantDefs +import ApiBase +import AppM +import Utils +import Lenses +import CryptoDef + +createTenant :: TenantIncoming -> AppM Tenant +createTenant tenant = do + auditable <$> createRow tenantTable tenant diff --git a/SpockOpaleye/src/Tenant/TenantDefs.hs b/SpockOpaleye/appcore/src/Tenant/TenantDefs.hs similarity index 96% rename from SpockOpaleye/src/Tenant/TenantDefs.hs rename to SpockOpaleye/appcore/src/Tenant/TenantDefs.hs index aedaab0..5034794 100644 --- a/SpockOpaleye/src/Tenant/TenantDefs.hs +++ b/SpockOpaleye/appcore/src/Tenant/TenantDefs.hs @@ -25,12 +25,7 @@ import Data.Char import Auditable import Prelude hiding(id) import qualified Data.HashMap.Strict as HM - -auditable :: a -> Auditable a -auditable a = Auditable {_data = a, _log = Object HM.empty} - -wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) -wrapAuditable a = (fmap auditable) <$> a +import Utils data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant { _tenantpolyId :: key diff --git a/SpockOpaleye/src/Tenant/TenantId.hs b/SpockOpaleye/appcore/src/Tenant/TenantId.hs similarity index 100% rename from SpockOpaleye/src/Tenant/TenantId.hs rename to SpockOpaleye/appcore/src/Tenant/TenantId.hs diff --git a/SpockOpaleye/appcore/src/User/UserApi.hs b/SpockOpaleye/appcore/src/User/UserApi.hs new file mode 100644 index 0000000..4b8c295 --- /dev/null +++ b/SpockOpaleye/appcore/src/User/UserApi.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module UserApi where + +import Control.Monad.IO.Class +import Control.Lens +import UserDefs +import ApiBase +import AppM +import Utils +import Lenses +import CryptoDef + +createUser :: UserIncoming -> AppM User +createUser user = do + Just hash <- liftIO $ bcryptPassword $ user ^. password + let fullUser = user { _userpolyPassword = hash } + auditable <$> (createRow userTable fullUser) diff --git a/SpockOpaleye/src/User/UserDefs.hs b/SpockOpaleye/appcore/src/User/UserDefs.hs similarity index 95% rename from SpockOpaleye/src/User/UserDefs.hs rename to SpockOpaleye/appcore/src/User/UserDefs.hs index 01189af..9c7d76e 100644 --- a/SpockOpaleye/src/User/UserDefs.hs +++ b/SpockOpaleye/appcore/src/User/UserDefs.hs @@ -26,12 +26,7 @@ import Auditable import Data.Char import Prelude hiding (id) import UserId - -auditable :: a -> Auditable a -auditable a = Auditable {_data = a, _log = Object HM.empty} - -wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) -wrapAuditable a = (fmap auditable) <$> a +import Utils data UserPoly key created_at updated_at tenant_id username password firstname lastname status = User { _userpolyId :: key diff --git a/SpockOpaleye/src/User/UserId.hs b/SpockOpaleye/appcore/src/User/UserId.hs similarity index 100% rename from SpockOpaleye/src/User/UserId.hs rename to SpockOpaleye/appcore/src/User/UserId.hs diff --git a/SpockOpaleye/appcore/src/Utils.hs b/SpockOpaleye/appcore/src/Utils.hs new file mode 100644 index 0000000..b66e48b --- /dev/null +++ b/SpockOpaleye/appcore/src/Utils.hs @@ -0,0 +1,12 @@ +module Utils where + +import Auditable +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM + +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a + diff --git a/SpockOpaleye/appcore/stack.yaml b/SpockOpaleye/appcore/stack.yaml new file mode 100644 index 0000000..0706908 --- /dev/null +++ b/SpockOpaleye/appcore/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.13 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.2" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/SpockOpaleye/appcore/test/Spec.hs b/SpockOpaleye/appcore/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/SpockOpaleye/appcore/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs index 8fcb2e9..b542d02 100644 --- a/SpockOpaleye/src/Email.hs +++ b/SpockOpaleye/src/Email.hs @@ -3,10 +3,10 @@ module Email where +import AppCore import Network.Mail.Mime import Network.Mail.SMTP hiding (simpleMail) -import ApiBase import Conf (apikey) import Control.Concurrent import Control.Lens @@ -17,10 +17,7 @@ import Data.String.Here import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.ByteString.Lazy as L -import DataTypes import System.FilePath (takeFileName) -import TenantDefs -import Lenses sendgridMail :: Mail -> IO () sendgridMail mail = do diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index 84bbc63..ebcac37 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -4,20 +4,13 @@ module JsonInstances where +import AppCore import Data.Aeson import Data.Aeson.Types import Data.Char import Data.Text -import DataTypes -import Auditable import qualified Data.HashMap.Strict as HM -auditable :: a -> Auditable a -auditable a = Auditable {_data = a, _log = Object HM.empty} - -wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) -wrapAuditable a = (fmap auditable) <$> a - instance (FromJSON a) => FromJSON (Auditable a) where parseJSON j = auditable <$> (parseJSON j) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 511ee9e..87fadf2 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,48 +5,32 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( createRole - , removeRole - , updateRole + ( + updateRole , readRolesForTenant ) where +import AppCore import Control.Arrow -import DataTypes import GHC.Int import Opaleye -import OpaleyeDef -import RoleDefs - -import ApiBase import Control.Lens import Prelude hiding (id) -import TenantId -import Auditable -import Lenses import Data.Aeson import Data.Aeson.Types import qualified Data.HashMap.Strict as HM -auditable :: a -> Auditable a -auditable a = Auditable {_data = a, _log = Object HM.empty} - -wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) -wrapAuditable a = (fmap auditable) <$> a - -createRole :: RoleIncoming -> AppM Role -createRole role = auditable <$> createRow roleTable role updateRole :: Role -> AppM Role updateRole role = updateAuditableRow roleTable role -removeRole :: Role -> AppM GHC.Int.Int64 -removeRole Auditable {_data = role} = do - _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) - removeRawDbRows roleTable matchFunc - where - tId = role ^. id - matchFunc role' = (role' ^. id).== constant tId +--removeRole :: Role -> AppM GHC.Int.Int64 +--removeRole Auditable {_data = role} = do +-- _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) +-- removeRawDbRows roleTable matchFunc +-- where +-- tId = role ^. id +-- matchFunc role' = (role' ^. id).== constant tId readRolesForTenant :: TenantId -> AppM [Role] readRolesForTenant tId = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index 624b513..c048856 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -15,27 +15,17 @@ module TenantApi , deactivateTenant ) where -import ApiBase +import AppCore import Control.Arrow import Control.Lens import Control.Monad.Reader import Data.Maybe import Data.Text -import DataTypes import GHC.Int import Opaleye -import OpaleyeDef import Prelude hiding (id) import RoleApi import UserApi -import Auditable -import Lenses -import TenantDefs -import TenantId - -createTenant :: TenantIncoming -> AppM Tenant -createTenant tenant = do - auditable <$> createRow tenantTable tenant activateTenant :: Tenant -> AppM Tenant activateTenant tenant = setTenantStatus tenant TenantStatusActive @@ -56,8 +46,8 @@ removeTenant tenant = do _ <- updateTenant (tenant_deac & ownerid .~ Nothing) usersForTenant <- readUsersForTenant tid rolesForTenant <- readRolesForTenant tid - mapM_ removeRole rolesForTenant - mapM_ removeUser usersForTenant + --mapM_ removeRole rolesForTenant + --mapM_ removeUser usersForTenant removeRawDbRows tenantTable matchFunc where tid = tenant ^. id diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 9d471da..86dad24 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -12,36 +12,19 @@ module UserApi , addRoleToUser , removeRoleFromUser , updateUser - , removeUser , activateUser , deactivateUser ) where -import ApiBase +import AppCore import Control.Arrow import Control.Lens import Control.Monad.IO.Class import Data.Maybe -import DataTypes import GHC.Int import Opaleye -import OpaleyeDef -import CryptoDef import Prelude hiding (id) -import RoleDefs -import UserDefs -import UserId -import TenantId - -import Auditable -import Lenses - -createUser :: UserIncoming -> AppM User -createUser user = do - Just hash <- liftIO $ bcryptPassword $ user ^. password - let fullUser = user { _userpolyPassword = hash } - auditable <$> (createRow userTable fullUser) updateUser :: User -> AppM User updateUser user = updateAuditableRow userTable user @@ -55,8 +38,8 @@ deactivateUser user = setUserStatus user UserStatusInActive setUserStatus :: User -> UserStatus -> AppM User setUserStatus user newStatus = updateUser $ user & status .~ newStatus -removeUser :: User -> AppM GHC.Int.Int64 -removeUser Auditable { _data = rUser} = removeRow userTable rUser +--removeUser :: User -> AppM GHC.Int.Int64 +--removeUser Auditable { _data = rUser} = removeRow userTable rUser readUsers :: AppM [User] readUsers = wrapAuditable $ readRow userQuery diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs index 07cfb31..82f0d60 100644 --- a/SpockOpaleye/src/UserServices.hs +++ b/SpockOpaleye/src/UserServices.hs @@ -2,16 +2,14 @@ module UserServices where +import AppCore import Control.Lens -import ApiBase import Email -import DataTypes import qualified Data.Text as T import Data.Monoid import Control.Monad.IO.Class import Validations import TenantApi -import TenantDefs doCreateTenant :: TenantIncoming -> AppM (Either T.Text Tenant) doCreateTenant incomingTenant = do diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index abfcd7f..3640d68 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -8,12 +8,10 @@ module Validations where +import AppCore import Control.Lens import qualified Data.Text as T -import DataTypes import TenantApi -import TenantDefs -import Lenses data ValidationResult = Valid | Invalid String deriving (Eq, Show) diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index 904eace..f41c090 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -38,6 +38,7 @@ resolver: lts-7.5 packages: - '.' - hs-airbrake +- appcore - location: git: https://github.com/agrafix/Spock.git commit: 77333a2de5dea0dc8eba9432ab16864e93e5d70e From 54dcd2eb92d7df09870ad01b6561f80d87478615 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 16 Dec 2016 17:29:09 +0000 Subject: [PATCH 68/69] Added removeAuditableRow function to api base --- SpockOpaleye/app/Main.hs | 2 -- SpockOpaleye/appcore/src/ApiBase.hs | 19 +++++++++++++++++++ SpockOpaleye/src/RoleAPi.hs | 15 ++++++++------- SpockOpaleye/src/TenantApi.hs | 4 ++-- SpockOpaleye/src/UserApi.hs | 5 +++-- 5 files changed, 32 insertions(+), 13 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 50b89c7..51c9c03 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -32,10 +32,8 @@ data MySession = data MyAppState = DummyAppState - data AppResult a = AppOk a | AppErr T.Text - connectDb :: IO Connection connectDb = connect defaultConnectInfo { connectDatabase = "haskell-webapps" } diff --git a/SpockOpaleye/appcore/src/ApiBase.hs b/SpockOpaleye/appcore/src/ApiBase.hs index 6174916..01fcb3b 100644 --- a/SpockOpaleye/appcore/src/ApiBase.hs +++ b/SpockOpaleye/appcore/src/ApiBase.hs @@ -130,6 +130,25 @@ insertIntoLog table auditable_id summary changes = do return () _ -> error "Unsupported Table constructor" +removeAuditableRow :: ( + Show haskells + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId + , HasId columnsR (Column PGInt4) + ) => Table columnsW columnsR -> Auditable haskells -> AppM GHC.Int.Int64 +removeAuditableRow table item_r = do + --auditLog $ "Remove : " ++ (show item) + conn <- getConnection + let Auditable { _data = item, _log = _log} = item_r + liftIO $ do + runDelete conn table $ matchFunc $ item ^. id + where + matchFunc :: ( + HasId columnsR (Column PGInt4), + D.Default Constant itemId (Column PGInt4) + ) => (itemId -> columnsR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== (constant itId) + removeRow :: ( Show haskells , D.Default Constant itemId (Column PGInt4) diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 87fadf2..4b26b52 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -7,6 +7,7 @@ module RoleApi ( updateRole + , removeRole , readRolesForTenant ) where @@ -24,13 +25,13 @@ import qualified Data.HashMap.Strict as HM updateRole :: Role -> AppM Role updateRole role = updateAuditableRow roleTable role ---removeRole :: Role -> AppM GHC.Int.Int64 ---removeRole Auditable {_data = role} = do --- _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) --- removeRawDbRows roleTable matchFunc --- where --- tId = role ^. id --- matchFunc role' = (role' ^. id).== constant tId +removeRole :: Role -> AppM GHC.Int.Int64 +removeRole role = do + _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) + removeRawDbRows roleTable matchFunc + where + tId = role ^. id + matchFunc role' = (role' ^. id).== constant tId readRolesForTenant :: TenantId -> AppM [Role] readRolesForTenant tId = do diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index c048856..fb7d73c 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -46,8 +46,8 @@ removeTenant tenant = do _ <- updateTenant (tenant_deac & ownerid .~ Nothing) usersForTenant <- readUsersForTenant tid rolesForTenant <- readRolesForTenant tid - --mapM_ removeRole rolesForTenant - --mapM_ removeUser usersForTenant + mapM_ removeRole rolesForTenant + mapM_ removeUser usersForTenant removeRawDbRows tenantTable matchFunc where tid = tenant ^. id diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 86dad24..a246690 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -12,6 +12,7 @@ module UserApi , addRoleToUser , removeRoleFromUser , updateUser + , removeUser , activateUser , deactivateUser ) where @@ -38,8 +39,8 @@ deactivateUser user = setUserStatus user UserStatusInActive setUserStatus :: User -> UserStatus -> AppM User setUserStatus user newStatus = updateUser $ user & status .~ newStatus ---removeUser :: User -> AppM GHC.Int.Int64 ---removeUser Auditable { _data = rUser} = removeRow userTable rUser +removeUser :: User -> AppM GHC.Int.Int64 +removeUser user = removeAuditableRow userTable user readUsers :: AppM [User] readUsers = wrapAuditable $ readRow userQuery From 39dbab3da5aff7b37da1683f75001cf5e8b8e400 Mon Sep 17 00:00:00 2001 From: "Sandeep.C.R" Date: Fri, 16 Dec 2016 17:56:15 +0000 Subject: [PATCH 69/69] Hide stuff in AppCore module --- SpockOpaleye/app/Main.hs | 3 +-- SpockOpaleye/appcore/src/AppCore.hs | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 51c9c03..8f20d8c 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -27,8 +27,7 @@ import Airbrake import Airbrake.WebRequest import Data.ByteString (ByteString) -data MySession = - EmptySession +data MySession = EmptySession data MyAppState = DummyAppState diff --git a/SpockOpaleye/appcore/src/AppCore.hs b/SpockOpaleye/appcore/src/AppCore.hs index 3464222..e6a6e2e 100644 --- a/SpockOpaleye/appcore/src/AppCore.hs +++ b/SpockOpaleye/appcore/src/AppCore.hs @@ -16,9 +16,9 @@ module AppCore ( ,wrapAuditable ) where -import UserDefs -import RoleDefs -import TenantDefs +import UserDefs hiding (InternalUser) +import RoleDefs hiding (InternalRole) +import TenantDefs hiding (InternalTenant) import TenantId import UserId import Lenses