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 -}