Start of Sprint 2 #49
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,157 @@ | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE FunctionalDependencies #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
|
|
||
| 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 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 | ||
| makeAudtableLenses ''Tenant | ||
| makeAudtableLenses ''User | ||
|
|
||
| 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) | ||
| => 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)) => 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 | ||
| matchFunc :: (HasId cmR (Column PGInt4)) => (Column PGInt4 -> cmR -> Column PGBool) | ||
| matchFunc itId item' = (item' ^. id) .== itId | ||
|
|
||
| createRow ::( | ||
| Show incoming, | ||
| Show columnsW, | ||
| HasCreatedat columnsW (Maybe (Column PGTimestamptz)), | ||
| HasUpdatedat columnsW (Column PGTimestamptz), | ||
| D.Default Constant incoming columnsW, D.Default QueryRunner returned row) | ||
| => 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 table [itemPg] | ||
|
|
||
| updateRow :: ( | ||
| Show columnsW | ||
| , Show haskells | ||
| , HasUpdatedat haskells UTCTime | ||
| , D.Default Constant haskells columnsW | ||
| , D.Default Constant itemId (Column PGInt4) | ||
| , HasId haskells itemId | ||
| , HasId columnsR (Column PGInt4) | ||
| ) | ||
| => 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 table (constant itId) (constant updatedItem) | ||
| return updatedItem | ||
| where | ||
| putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item | ||
| putUpdatedTimestamp timestamp = updatedat .~ timestamp | ||
|
|
||
| updateAuditableRow :: ( | ||
|
There was a problem hiding this comment. shouldn't this be in a DB transaction? Have we solved for DB transaction yets? |
||
| 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 = _log} = updatedItem | ||
| _ <- updateDbRow table (constant itId) (constant item) | ||
|
There was a problem hiding this comment. should we really be ignoring the result? Isn't it better to use |
||
| insertIntoLog table itId "" _log | ||
| return audti | ||
|
There was a problem hiding this comment. is the in-memory audit log being blanked out after a successful update or insert? There was a problem hiding this comment. No. I completely missed that. Will do. |
||
| 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) | ||
| , HasId haskells itemId | ||
| , HasId columnsR (Column PGInt4) | ||
| ) => 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 | ||
| matchFunc :: ( | ||
| HasId columnsR (Column PGInt4), | ||
| 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' | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
shouldn't we be using
runUpdateReturninghere?There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Yes. That would be ideal. But since we already hold the record in its updated state, I thought, why do the additional fetching. If there was a failure with update, we will get an exception anyway, right?
I am not sure, but I think the use case of "update returning" would be if we are doing an operation on existing value, like "update product set quantity = quantity + 1", and in that case, returning the new values can save an additional select.
But here we are not doing anything like that.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I feel kts better to use updateReturning because it allows us to represent the latest state of the row in the DB, which might be different than what is in the memory, possibly due to DB triggers.