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