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