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   ]