1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, DataKinds, ViewPatterns #-} 2 module Model.RecordSlot 3 ( module 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 Ops 26 import qualified JSON 27 import Service.DB 28 import Model.Id.Types 29 import Model.Segment 30 import Model.Permission 31 import Model.Audit 32 import Model.Audit.SQL 33 import Model.Volume.Types 34 import Model.Container.Types 35 import Model.Slot 36 import Model.Metric 37 import Model.Record 38 import Model.Age 39 import Model.Measure 40 import Model.SQL 41 import Model.RecordSlot.Types 42 import 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 -}