1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, DataKinds, ViewPatterns #-} 2 module Databrary.Model.RecordSlot 3 ( module Databrary.Model.RecordSlot.Types 4 , lookupRecordSlots 5 , lookupSlotRecords 6 , lookupContainerRecords 7 , lookupRecordSlotRecords 8 , lookupVolumeContainersRecords 9 , lookupVolumeContainersRecordIds 10 , lookupVolumeRecordSlotIds 11 , moveRecordSlot 12 , removeRecordAllSlot 13 , recordSlotAge 14 , recordSlotJSON 15 ) where 16 17 import Control.Arrow (second) 18 import Control.Monad (guard, liftM2) 19 import Data.Function (on) 20 import Data.Maybe (catMaybes) 21 import Data.Monoid ((<>)) 22 import qualified Database.PostgreSQL.Typed.Range as Range 23 import Database.PostgreSQL.Typed.Types (PGTypeName(..)) 24 25 import Databrary.Ops 26 import qualified Databrary.JSON as JSON 27 import Databrary.Service.DB 28 import Databrary.Model.Id.Types 29 import Databrary.Model.Segment 30 import Databrary.Model.Permission 31 import Databrary.Model.Audit 32 import Databrary.Model.Audit.SQL 33 import Databrary.Model.Volume.Types 34 import Databrary.Model.Container.Types 35 import Databrary.Model.Slot 36 import Databrary.Model.Metric 37 import Databrary.Model.Record 38 import Databrary.Model.Age 39 import Databrary.Model.Measure 40 import Databrary.Model.SQL 41 import Databrary.Model.RecordSlot.Types 42 import Databrary.Model.RecordSlot.SQL 43 44 lookupRecordSlots :: (MonadDB c m) => Record -> m [RecordSlot] 45 lookupRecordSlots r = 46 dbQuery $ ($ r) <$> $(selectQuery selectRecordSlotRecord "$WHERE slot_record.record = ${recordId $ recordRow r}") 47 48 lookupSlotRecords :: (MonadDB c m) => Slot -> m [RecordSlot] 49 lookupSlotRecords (Slot c s) = 50 dbQuery $ ($ c) <$> $(selectQuery selectContainerSlotRecord "$WHERE slot_record.container = ${containerId $ containerRow c} AND slot_record.segment && ${s}") 51 52 lookupContainerRecords :: (MonadDB c m) => Container -> m [RecordSlot] 53 lookupContainerRecords = lookupSlotRecords . containerSlot 54 55 lookupRecordSlotRecords :: (MonadDB c m) => Record -> Slot -> m [RecordSlot] 56 lookupRecordSlotRecords r (Slot c s) = 57 dbQuery $ ($ c) . ($ r) <$> $(selectQuery selectRecordContainerSlotRecord "WHERE slot_record.record = ${recordId $ recordRow r} AND slot_record.container = ${containerId $ containerRow c} AND slot_record.segment && ${s}") 58 59 lookupVolumeContainersRecords :: (MonadDB c m) => Volume -> m [(Container, [RecordSlot])] 60 lookupVolumeContainersRecords v = 61 map (second catMaybes) . groupTuplesBy ((==) `on` containerId . containerRow) <$> 62 dbQuery (($ v) <$> $(selectQuery selectVolumeSlotMaybeRecord "WHERE container.volume = ${volumeId $ volumeRow v} ORDER BY container.id, record.category NULLS FIRST, slot_record.segment, slot_record.record")) 63 64 lookupVolumeContainersRecordIds :: (MonadDB c m) => Volume -> m [(Container, [(Segment, Id Record)])] 65 lookupVolumeContainersRecordIds v = 66 map (second catMaybes) . groupTuplesBy ((==) `on` containerId . containerRow) <$> 67 dbQuery (($ v) <$> $(selectQuery selectVolumeSlotMaybeRecordId "$WHERE container.volume = ${volumeId $ volumeRow v} ORDER BY container.id, slot_record.segment, slot_record.record")) 68 69 lookupVolumeRecordSlotIds :: (MonadDB c m) => Volume -> m [(Record, SlotId)] 70 lookupVolumeRecordSlotIds v = 71 dbQuery (($ v) <$> $(selectQuery selectVolumeSlotIdRecord "WHERE record.volume = ${volumeId $ volumeRow v} ORDER BY container")) 72 73 moveRecordSlot :: (MonadAudit c m) => RecordSlot -> Segment -> m Bool 74 moveRecordSlot rs@RecordSlot{ recordSlot = s@Slot{ slotSegment = src } } dst = do 75 ident <- getAuditIdentity 76 either (const False) id 77 <$> case (Range.isEmpty (segmentRange src), Range.isEmpty (segmentRange dst)) of 78 (True, True) -> return $ Right False 79 (False, True) -> Right <$> dbExecute1 $(deleteSlotRecord 'ident 'rs) 80 (True, False) -> dbTryJust err $ dbExecute1 $(insertSlotRecord 'ident 'rd) 81 (False, False) -> dbTryJust err $ dbExecute1 $(updateSlotRecord 'ident 'rs 'dst) 82 where 83 rd = rs{ recordSlot = s{ slotSegment = dst } } 84 err = guard . isExclusionViolation 85 86 removeRecordAllSlot :: (MonadAudit c m) => Record -> m Int 87 removeRecordAllSlot r = do 88 ident <- getAuditIdentity 89 dbExecute $(auditDelete 'ident "slot_record" "record = ${recordId $ recordRow r} AND segment = '(,)'" Nothing) 90 91 recordSlotAge :: RecordSlot -> Maybe Age 92 recordSlotAge rs@RecordSlot{..} = 93 clip <$> liftM2 age (decodeMeasure (PGTypeProxy :: PGTypeName "date") =<< getMeasure birthdateMetric (recordMeasures slotRecord)) (containerDate $ containerRow $ slotContainer recordSlot) 94 where 95 clip a 96 | not (canReadData2 getRecordSlotRelease getRecordSlotVolumePermission rs) = a `min` ageLimit 97 | otherwise = a 98 99 recordSlotJSON :: JSON.ToObject o => Bool -> RecordSlot -> JSON.Record (Id Record) o 100 recordSlotJSON _ rs@RecordSlot{..} = JSON.Record (recordId $ recordRow slotRecord) $ 101 segmentJSON (slotSegment recordSlot) 102 <> "age" `JSON.kvObjectOrEmpty` recordSlotAge rs 103 104 {- 105 recordSlotJSONRestricted :: JSON.ToObject o => RecordSlot -> JSON.Record (Id Record) o 106 recordSlotJSONRestricted rs@RecordSlot{..} = JSON.Record (recordId $ recordRow slotRecord) $ 107 segmentJSON (slotSegment recordSlot) 108 <> "age" `JSON.kvObjectOrEmpty` recordSlotAge rs -- allow age to pass through so that summary can be computed 109 -}