1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-} 2 module Databrary.Model.RecordSlot.SQL 3 ( selectRecordContainerSlotRecord 4 , selectContainerSlotRecord 5 , selectRecordSlotRecord 6 , selectVolumeSlotRecord 7 , selectVolumeSlotIdRecord 8 , selectVolumeSlotMaybeRecord 9 , selectVolumeSlotMaybeRecordId 10 , selectSlotRecord 11 , insertSlotRecord 12 , updateSlotRecord 13 , deleteSlotRecord 14 ) where 15 16 import qualified Language.Haskell.TH as TH 17 18 import Databrary.Has (view) 19 import Databrary.Model.Id.Types 20 import Databrary.Model.Segment 21 import Databrary.Model.Volume.Types 22 import Databrary.Model.Record.Types 23 import Databrary.Model.Record.SQL 24 import Databrary.Model.Container.Types 25 import Databrary.Model.Container.SQL 26 import Databrary.Model.Slot.Types 27 import Databrary.Model.SQL.Select 28 import Databrary.Model.Audit.SQL 29 import Databrary.Model.Volume.SQL 30 import Databrary.Model.RecordSlot.Types 31 32 slotRecordRow :: Selector -- ^ @'Segment'@ 33 slotRecordRow = selectColumn "slot_record" "segment" 34 35 makeSlotRecord :: Segment -> Record -> Container -> RecordSlot 36 makeSlotRecord seg r c = RecordSlot r (Slot c seg) 37 38 selectRecordContainerSlotRecord :: Selector -- ^ @'Record' -> 'Container' -> 'RecordSlot'@ 39 selectRecordContainerSlotRecord = selectMap (TH.VarE 'makeSlotRecord `TH.AppE`) slotRecordRow 40 41 makeContainerSlotRecord :: (Record -> Container -> RecordSlot) -> (Volume -> Record) -> Container -> RecordSlot 42 makeContainerSlotRecord f rf c = f (rf (view c)) c 43 44 selectContainerSlotRecord :: Selector -- ^ @'Container' -> 'RecordSlot'@ 45 selectContainerSlotRecord = selectJoin 'makeContainerSlotRecord 46 [ selectRecordContainerSlotRecord 47 , joinOn "slot_record.record = record.id" 48 selectVolumeRecord -- XXX volumes match? 49 ] 50 51 makeRecordSlotRecord :: (Record -> Container -> RecordSlot) -> (Volume -> Container) -> Record -> RecordSlot 52 makeRecordSlotRecord f cf r = f r (cf (view r)) 53 54 selectRecordSlotRecord :: Selector -- ^ @'Record' -> 'RecordSlot'@ 55 selectRecordSlotRecord = selectJoin 'makeRecordSlotRecord 56 [ selectRecordContainerSlotRecord 57 , joinOn "slot_record.container = container.id" 58 selectVolumeContainer -- XXX volumes match? 59 ] 60 61 makeVolumeSlotRecord :: (Record -> Container -> RecordSlot) -> (Volume -> Record) -> (Volume -> Container) -> Volume -> RecordSlot 62 makeVolumeSlotRecord f rf cf v = f (rf v) (cf v) 63 64 selectVolumeSlotRecord :: Selector -- ^ @'Volume' -> 'RecordSlot'@ 65 selectVolumeSlotRecord = selectJoin 'makeVolumeSlotRecord 66 [ selectRecordContainerSlotRecord 67 , joinOn "slot_record.record = record.id" 68 selectVolumeRecord 69 , joinOn "slot_record.container = container.id AND record.volume = container.volume" 70 selectVolumeContainer 71 ] 72 73 makeVolumeSlotIdRecord :: SlotId -> (Volume -> Record) -> Volume -> (Record, SlotId) 74 makeVolumeSlotIdRecord s rf v = (rf v, s) 75 76 selectVolumeSlotIdRecord :: Selector -- ^ @'Volume' -> ('Record', 'SlotId')@ 77 selectVolumeSlotIdRecord = selectJoin 'makeVolumeSlotIdRecord 78 [ selectColumns 'SlotId "slot_record" ["container", "segment"] 79 , joinOn "slot_record.record = record.id" 80 selectVolumeRecord --- XXX volumes match? 81 ] 82 83 makeVolumeSlotMaybeRecord :: (Volume -> Container) -> Maybe (Container -> RecordSlot) -> Volume -> (Container, Maybe RecordSlot) 84 makeVolumeSlotMaybeRecord cf Nothing v = (cf v, Nothing) 85 makeVolumeSlotMaybeRecord cf (Just rf) v = (c, Just (rf c)) where c = cf v 86 87 selectVolumeSlotMaybeRecord :: Selector -- ^ @'Volume' -> ('Container, Maybe 'RecordSlot)@ 88 selectVolumeSlotMaybeRecord = selectJoin 'makeVolumeSlotMaybeRecord 89 [ selectVolumeContainer 90 , maybeJoinOn "container.id = slot_record.container AND container.volume = record.volume" 91 selectContainerSlotRecord 92 ] 93 94 segmentRecordIdTuple :: Segment -> Id Record -> (Segment, Id Record) 95 segmentRecordIdTuple = (,) 96 97 makeVolumeContainerTuple :: (Volume -> Container) -> a -> Volume -> (Container, a) 98 makeVolumeContainerTuple cf a v = (cf v, a) 99 100 selectVolumeSlotMaybeRecordId :: Selector -- ^ @'Volume' -> ('Container', Maybe ('Segment', 'Id' 'Record'))@ 101 selectVolumeSlotMaybeRecordId = selectJoin 'makeVolumeContainerTuple 102 [ selectVolumeContainer 103 , maybeJoinOn "container.id = slot_record.container" 104 $ selectColumns 'segmentRecordIdTuple "slot_record" ["segment", "record"] 105 ] 106 107 selectSlotRecord :: TH.Name -- ^ @'Identity'@ 108 -> Selector -- ^ @'RecordSlot'@ 109 selectSlotRecord ident = selectJoin '($) 110 [ selectVolumeSlotRecord 111 , joinOn "record.volume = volume.id" 112 $ selectVolume ident 113 ] 114 115 slotRecordVals :: String -- ^ @'RecordSlot'@ 116 -> [(String, String)] 117 slotRecordVals o = 118 [ ("record", "${recordId $ recordRow $ slotRecord " ++ o ++ "}") 119 , ("container", "${containerId $ containerRow $ slotContainer $ recordSlot " ++ o ++ "}") 120 , ("segment", "${slotSegment $ recordSlot " ++ o ++ "}") 121 ] 122 123 insertSlotRecord :: TH.Name -- ^ @'AuditIdentity'@ 124 -> TH.Name -- ^ @'RecordSlot'@ 125 -> TH.ExpQ 126 insertSlotRecord ident o = auditInsert ident "slot_record" 127 (slotRecordVals os) 128 Nothing 129 where os = nameRef o 130 131 updateSlotRecord :: TH.Name -- ^ @'AuditIdentity'@ 132 -> TH.Name -- ^ @'RecordSlot'@ 133 -> TH.Name -- ^ @'Segment'@ 134 -> TH.ExpQ 135 updateSlotRecord ident o ds = auditUpdate ident "slot_record" 136 [ ("segment", "${" ++ nameRef ds ++ "}") ] 137 (whereEq $ slotRecordVals $ nameRef o) 138 Nothing 139 140 deleteSlotRecord :: TH.Name -- ^ @'AuditIdentity'@ 141 -> TH.Name -- ^ @'RecordSlot'@ 142 -> TH.ExpQ 143 deleteSlotRecord ident o = auditDelete ident "slot_record" 144 ("record = ${recordId $ recordRow $ slotRecord " ++ os ++ "} AND container = ${containerId $ containerRow $ slotContainer $ recordSlot " ++ os ++ "} AND segment <@ ${slotSegment $ recordSlot " ++ os ++ "}") 145 Nothing 146 where os = nameRef o