1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-} 2 module Databrary.Model.Record 3 ( module Databrary.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 Databrary.Has (peek, view) 28 import Databrary.Service.DB 29 import qualified Databrary.JSON as JSON 30 import Databrary.Model.SQL 31 import Databrary.Model.Audit 32 import Databrary.Model.Id 33 import Databrary.Model.Identity.Types 34 import Databrary.Model.Volume.Types 35 import Databrary.Model.Party.Types 36 import Databrary.Model.Category 37 import Databrary.Model.Measure 38 import Databrary.Model.Metric 39 import Databrary.Model.Record.Types 40 import Databrary.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 (\hdr -> extractColumnDefaulting hdr 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 ]