1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-} 2 module Model.Record 3 ( module Model.Record.Types 4 , lookupRecord 5 , lookupVolumeRecord 6 , lookupVolumeParticipant 7 , lookupVolumeRecords 8 , addRecord 9 , changeRecord 10 , removeRecord 11 , recordJSON 12 , columnSampleJson 13 -- , recordJSONRestricted 14 -- for testing only 15 , extractParticipantFieldRows 16 ) where 17 18 import Control.Monad (guard) 19 import qualified Data.ByteString as BS 20 import qualified Data.Csv as CSV 21 import Data.Either (isRight) 22 import Data.List (find) 23 import Data.Monoid ((<>)) 24 import Data.Vector (Vector) 25 26 import Data.Csv.Contrib (extractColumnDefaulting) 27 import Has (peek, view) 28 import Service.DB 29 import qualified JSON 30 import Model.SQL 31 import Model.Audit 32 import Model.Id 33 import Model.Identity.Types 34 import Model.Volume.Types 35 import Model.Party.Types 36 import Model.Category 37 import Model.Measure 38 import Model.Metric 39 import Model.Record.Types 40 import Model.Record.SQL 41 42 lookupRecord :: (MonadHasIdentity c m, MonadDB c m) => Id Record -> m (Maybe Record) 43 lookupRecord ri = do 44 ident <- peek 45 dbQuery1 $(selectQuery (selectRecord 'ident) "$WHERE record.id = ${ri}") 46 47 lookupVolumeRecord :: MonadDB c m => Volume -> Id Record -> m (Maybe Record) 48 lookupVolumeRecord vol ri = 49 dbQuery1 $ fmap ($ vol) $(selectQuery selectVolumeRecord "$WHERE record.id = ${ri} AND record.volume = ${volumeId $ volumeRow vol}") 50 51 lookupVolumeParticipant :: MonadDB c m => Volume -> MeasureDatum -> m (Maybe Record) 52 lookupVolumeParticipant vol idMeasureVal = do 53 allVolumeRecords <- lookupVolumeRecords vol 54 let mIdMatch = find matchesId allVolumeRecords 55 -- check record type is participant, if not, then error 56 pure mIdMatch 57 where 58 idMetric :: Metric 59 idMetric = getMetric' (Id 1) 60 matchesId :: Record -> Bool 61 matchesId r = 62 maybe 63 False 64 (const True) 65 (find (\msr -> measureMetric msr == idMetric && measureDatum msr == idMeasureVal) (recordMeasures r)) 66 67 lookupVolumeRecords :: MonadDB c m => Volume -> m [Record] 68 lookupVolumeRecords vol = 69 dbQuery $ fmap ($ vol) $(selectQuery selectVolumeRecord "$WHERE record.volume = ${volumeId $ volumeRow vol}") 70 71 addRecord :: MonadAudit c m => Record -> m Record 72 addRecord br = do 73 ident <- getAuditIdentity 74 dbQuery1' $(insertRecord 'ident 'br) 75 76 changeRecord :: MonadAudit c m => Record -> m () 77 changeRecord r = do 78 ident <- getAuditIdentity 79 dbExecute1' $(updateRecord 'ident 'r) 80 81 removeRecord :: MonadAudit c m => Record -> m Bool 82 removeRecord r = do 83 ident <- getAuditIdentity 84 isRight <$> dbTryJust (guard . isForeignKeyViolation) (dbExecute1 $(deleteRecord 'ident 'r)) 85 86 recordJSON :: JSON.ToNestedObject o u => Bool -> Record -> JSON.Record (Id Record) o 87 recordJSON publicRestricted r@Record{ recordRow = RecordRow{..}, ..} = JSON.Record recordId $ 88 -- "volume" JSON..= volumeId recordVolume 89 "category" JSON..= categoryId recordCategory 90 <> "measures" JSON..=. measuresJSON publicRestricted (getRecordMeasures r) 91 92 extractParticipantFieldRows :: [BS.ByteString] -> Vector CSV.NamedRecord -> [(BS.ByteString, [BS.ByteString])] 93 extractParticipantFieldRows participantFieldHeaders records = 94 (zip participantFieldHeaders . fmap (`extractColumnDefaulting` records)) participantFieldHeaders 95 96 columnSampleJson :: BS.ByteString -> [BS.ByteString] -> JSON.Value 97 columnSampleJson hdr sampleValues = 98 JSON.object [ 99 "column_name" JSON..= hdr 100 , "samples" JSON..= sampleValues 101 ]