1 module Model.AssetSegment.Types 2 ( AssetSegment(..) 3 , getAssetSegmentRelease2 4 , getAssetSegmentVolumePermission2 5 , getAssetSegmentVolume 6 , newAssetSegment 7 , assetFullSegment 8 , assetSlotSegment 9 , assetSegmentFull 10 , assetSegmentRange 11 , Excerpt(..) 12 , newExcerpt 13 , excerptInSegment 14 ) where 15 16 import Data.Foldable (fold) 17 import Data.Maybe (fromMaybe) 18 import Data.Monoid ((<>)) 19 import qualified Database.PostgreSQL.Typed.Range as Range 20 21 import Ops 22 import Has (Has(..)) 23 import Model.Offset 24 import Model.Segment 25 import Model.Id.Types 26 import Model.Permission.Types 27 import Model.Volume.Types 28 import Model.Release.Types 29 import Model.Container.Types 30 import Model.Slot.Types 31 import Model.Format 32 import Model.Asset.Types 33 import Model.AssetSlot.Types 34 35 data AssetSegment = AssetSegment 36 { segmentAsset :: AssetSlot 37 , assetSegment :: !Segment 38 , assetExcerpt :: Maybe Excerpt 39 } 40 41 assetAssumedSegment :: AssetSlot -> Segment 42 assetAssumedSegment a 43 | segmentFull seg = Segment $ Range.bounded 0 $ fromMaybe 0 $ assetDuration $ assetRow $ slotAsset a 44 | otherwise = seg where seg = view a 45 46 -- |A "fake" (possibly invalid) 'AssetSegment' corresponding to the full 'AssetSlot' 47 assetSlotSegment :: AssetSlot -> AssetSegment 48 assetSlotSegment a = AssetSegment a (assetAssumedSegment a) Nothing 49 50 assetFullSegment :: AssetSegment -> AssetSegment 51 assetFullSegment AssetSegment{ assetExcerpt = Just e } = excerptFullSegment e 52 assetFullSegment AssetSegment{ segmentAsset = a } = assetSlotSegment a 53 54 newAssetSegment :: AssetSlot -> Segment -> Maybe Excerpt -> AssetSegment 55 newAssetSegment a s e = AssetSegment a (assetAssumedSegment a `segmentIntersect` s) e 56 57 assetSegmentFull :: AssetSegment -> Bool 58 assetSegmentFull AssetSegment{ segmentAsset = a, assetSegment = s } = assetAssumedSegment a == s 59 60 assetSegmentRange :: AssetSegment -> Range.Range Offset 61 assetSegmentRange AssetSegment{ segmentAsset = a, assetSegment = Segment s } = 62 maybe id (fmap . subtract) (lowerBound $ segmentRange $ assetAssumedSegment a) s 63 64 instance Has AssetSlot AssetSegment where 65 view = segmentAsset 66 instance Has Asset AssetSegment where 67 view = view . segmentAsset 68 instance Has (Id Asset) AssetSegment where 69 view = view . segmentAsset 70 getAssetSegmentVolume :: AssetSegment -> Volume 71 getAssetSegmentVolume = getAssetSlotVolume . segmentAsset 72 instance Has Volume AssetSegment where 73 view = view . segmentAsset 74 instance Has (Id Volume) AssetSegment where 75 view = volumeId . volumeRow . assetVolume . slotAsset . segmentAsset 76 getAssetSegmentVolumePermission2 :: AssetSegment -> VolumeRolePolicy 77 getAssetSegmentVolumePermission2 = getAssetSlotVolumePermission2 . segmentAsset 78 79 instance Has Slot AssetSegment where 80 view AssetSegment{ segmentAsset = AssetSlot{ assetSlot = Just s }, assetSegment = seg } = s{ slotSegment = seg } 81 view _ = error "unlinked AssetSegment" 82 instance Has Container AssetSegment where 83 view = slotContainer . view 84 instance Has (Id Container) AssetSegment where 85 view = containerId . containerRow . slotContainer . view 86 instance Has Segment AssetSegment where 87 view = assetSegment 88 89 instance Has Format AssetSegment where 90 view AssetSegment{ segmentAsset = a, assetSegment = Segment rng } 91 | Just s <- formatSample fmt 92 , Just _ <- assetDuration $ assetRow $ slotAsset a 93 , Just _ <- Range.getPoint rng = s 94 | otherwise = fmt 95 where fmt = getAssetSlotFormat a 96 instance Has (Id Format) AssetSegment where 97 view = formatId . view 98 99 -- when the assetslot has lower permissions than the excerpt, then use the excerpt's permissions 100 -- when no excerpt is present, then assume no access 101 getAssetSegmentRelease2 :: AssetSegment -> EffectiveRelease 102 getAssetSegmentRelease2 as = 103 case as of 104 AssetSegment{ segmentAsset = a, assetExcerpt = Just e } -> 105 let 106 rel = 107 fold ( 108 excerptRelease e -- Maybe Release monoid takes the first just, if both just, then max of values 109 <> getAssetSlotReleaseMaybe a) -- TODO: should I expose the guts of getAssetSlotRelease2? 110 in 111 EffectiveRelease { 112 effRelPublic = rel 113 , effRelPrivate = rel 114 } 115 AssetSegment{ segmentAsset = a } -> 116 getAssetSlotRelease2 a 117 118 data Excerpt = Excerpt 119 { excerptAsset :: !AssetSegment 120 , excerptRelease :: !(Maybe Release) 121 } 122 instance Show Excerpt where 123 show _ = "Excerpt" 124 125 newExcerpt :: AssetSlot -> Segment -> Maybe Release -> Excerpt 126 newExcerpt a s r = e where 127 as = newAssetSegment a s (Just e) 128 e = Excerpt as r 129 130 excerptInSegment :: Excerpt -> Segment -> AssetSegment 131 excerptInSegment e@Excerpt{ excerptAsset = AssetSegment{ segmentAsset = a, assetSegment = es } } s 132 | segmentOverlaps es s = as 133 | otherwise = error "excerptInSegment: non-overlapping" 134 where as = newAssetSegment a s ((es `segmentContains` assetSegment as) `thenUse` e) 135 136 excerptFullSegment :: Excerpt -> AssetSegment 137 excerptFullSegment e = excerptInSegment e fullSegment 138 139 instance Has AssetSegment Excerpt where 140 view = excerptAsset 141 instance Has AssetSlot Excerpt where 142 view = view . excerptAsset 143 instance Has Asset Excerpt where 144 view = view . excerptAsset 145 instance Has (Id Asset) Excerpt where 146 view = view . excerptAsset 147 instance Has Volume Excerpt where 148 view = view . excerptAsset 149 {- instance Has (Id Volume) Excerpt where 150 view = view . excerptAsset -} 151 instance Has Slot Excerpt where 152 view = view . excerptAsset 153 instance Has Container Excerpt where 154 view = view . excerptAsset 155 instance Has (Id Container) Excerpt where 156 view = view . excerptAsset 157 instance Has Segment Excerpt where 158 view = view . excerptAsset