1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
    2 module Databrary.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 Databrary.Model.SQL.Select
   14 import Databrary.Model.Release.Types
   15 import Databrary.Model.Segment
   16 import Databrary.Model.Volume.Types
   17 import Databrary.Model.Volume.SQL
   18 import Databrary.Model.Container.Types
   19 import Databrary.Model.Container.SQL
   20 import Databrary.Model.Asset.Types
   21 import Databrary.Model.Asset.SQL
   22 import Databrary.Model.AssetSlot.Types
   23 import Databrary.Model.AssetSlot.SQL
   24 import Databrary.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   ]