1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-} 2 module Model.AssetSegment.SQL 3 ( excerptRow 4 , makeExcerpt 5 , selectAssetSegment 6 , selectContainerAssetSegment 7 -- , selectAssetAssetSegment 8 ) where 9 10 import Data.Maybe (fromMaybe) 11 import qualified Language.Haskell.TH as TH 12 13 import Model.SQL.Select 14 import Model.Release.Types 15 import Model.Segment 16 import Model.Volume.Types 17 import Model.Volume.SQL 18 import Model.Container.Types 19 import Model.Container.SQL 20 import Model.Asset.Types 21 import Model.Asset.SQL 22 import Model.AssetSlot.Types 23 import Model.AssetSlot.SQL 24 import Model.AssetSegment.Types 25 26 excerptTuple :: Segment -> Maybe Release -> (Segment, Maybe Release) 27 excerptTuple = (,) 28 29 excerptRow :: Selector -- ^ @('Segment', Maybe 'Release')@ 30 excerptRow = selectColumns 'excerptTuple "excerpt" ["segment", "release"] 31 32 makeExcerpt :: AssetSlot -> Segment -> Maybe (Segment, Maybe Release) -> AssetSegment 33 makeExcerpt a s = newAssetSegment a s . fmap (uncurry $ newExcerpt a) 34 35 makeAssetSegment :: Segment -> Maybe Segment -> Maybe (Segment, Maybe Release) -> Asset -> Container -> AssetSegment 36 makeAssetSegment as ss e a c = makeExcerpt sa ss' e where 37 sa = makeSlotAsset a c as 38 ss' = fromMaybe emptySegment ss -- should not happen 39 40 selectAssetContainerAssetSegment :: TH.Name -- ^ @'Segment'@ 41 -> Selector -- ^ @'Asset' -> 'Container' -> 'AssetSegment'@ 42 selectAssetContainerAssetSegment seg = selectJoin 'makeAssetSegment 43 [ slotAssetRow 44 , crossJoin 45 $ selector ("LATERAL (VALUES (slot_asset.segment * ${" ++ nameRef seg ++ "})) AS asset_segment (segment)") 46 $ SelectColumn "asset_segment" "segment" 47 -- asset_segment.segment <@ excerpt.segment == the range of the segment is contained in the range of the excerpt 48 , maybeJoinOn "slot_asset.asset = excerpt.asset AND asset_segment.segment <@ excerpt.segment" 49 excerptRow 50 ] 51 52 makeContainerAssetSegment :: (Asset -> Container -> AssetSegment) -> AssetRow -> Container -> AssetSegment 53 makeContainerAssetSegment f ar c = f (Asset ar $ containerVolume c) c 54 55 selectContainerAssetSegment :: TH.Name -- ^ @'Segment'@ 56 -> Selector -- ^ @'Container' -> 'AssetSegment'@ 57 selectContainerAssetSegment seg = selectJoin 'makeContainerAssetSegment 58 [ selectAssetContainerAssetSegment seg 59 , joinOn "slot_asset.asset = asset.id" 60 selectAssetRow -- XXX volumes match? 61 ] 62 63 {- 64 makeAssetAssetSegment :: (Asset -> Container -> AssetSegment) -> (Volume -> Container) -> Asset -> AssetSegment 65 makeAssetAssetSegment f cf a = f a (cf (assetVolume a)) 66 67 selectAssetAssetSegment :: TH.Name -- ^ @'Segment'@ 68 -> Selector -- ^ @'Container' -> 'AssetSegment'@ 69 selectAssetAssetSegment seg = selectJoin 'makeAssetAssetSegment 70 [ selectAssetContainerAssetSegment seg 71 , joinOn "slot_asset.container = container.id" 72 selectVolumeContainer -- XXX volumes match? 73 ] 74 -} 75 76 makeVolumeAssetSegment :: (Asset -> Container -> AssetSegment) -> AssetRow -> (Volume -> Container) -> Volume -> AssetSegment 77 makeVolumeAssetSegment f ar cf v = f (Asset ar v) (cf v) 78 79 selectVolumeAssetSegment :: TH.Name -- ^ @'Segment'@ 80 -> Selector -- ^ @'Volume' -> 'AssetSegment'@ 81 selectVolumeAssetSegment seg = selectJoin 'makeVolumeAssetSegment 82 [ selectAssetContainerAssetSegment seg 83 , joinOn "slot_asset.asset = asset.id" 84 selectAssetRow 85 , joinOn "slot_asset.container = container.id AND asset.volume = container.volume" 86 selectVolumeContainer 87 ] 88 89 selectAssetSegment :: TH.Name -- ^ @'Identity'@ 90 -> TH.Name -- ^ @'Segment'@ 91 -> Selector -- ^ @'AssetSegment'@ 92 selectAssetSegment ident seg = selectJoin '($) 93 [ selectVolumeAssetSegment seg 94 , joinOn "asset.volume = volume.id" 95 $ selectVolume ident 96 ]