1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, DataKinds #-} 2 module Databrary.Model.AssetSlot 3 ( module Databrary.Model.AssetSlot.Types 4 , lookupAssetSlot 5 , lookupOrigAssetSlot 6 , lookupAssetAssetSlot 7 , lookupSlotAssets 8 , lookupOrigSlotAssets 9 , lookupContainerAssets 10 , lookupOrigContainerAssets 11 , lookupVolumeAssetSlots 12 -- , lookupOrigVolumeAssetSlots 13 , lookupOrigVolumeAssetSlots' 14 , lookupVolumeAssetSlotIds 15 -- , lookupOrigVolumeAssetSlotIds 16 , changeAssetSlot 17 , changeAssetSlotDuration 18 , fixAssetSlotDuration 19 , findAssetContainerEnd 20 , assetSlotName 21 , assetSlotJSON 22 ) where 23 24 import Control.Monad (when, guard) 25 import qualified Data.ByteString 26 import Data.Maybe (fromMaybe, isNothing) 27 import Data.Monoid ((<>)) 28 import Data.Maybe (fromJust, catMaybes) 29 import Data.String 30 import qualified Data.Text as T 31 -- import Database.PostgreSQL.Typed (pgSQL) 32 import Database.PostgreSQL.Typed.Types 33 34 import Databrary.Ops 35 import Databrary.Has (peek, view) 36 import qualified Databrary.JSON as JSON 37 import Databrary.Service.DB 38 import Databrary.Model.Offset 39 import Databrary.Model.Permission 40 import Databrary.Model.Segment 41 import Databrary.Model.Id 42 import Databrary.Model.Party.Types 43 import Databrary.Model.Identity.Types 44 import Databrary.Model.Volume.Types 45 import Databrary.Model.Container.Types 46 import Databrary.Model.Slot.Types 47 import Databrary.Model.Asset 48 import Databrary.Model.Audit 49 import Databrary.Model.SQL 50 import Databrary.Model.AssetSlot.Types 51 import Databrary.Model.AssetSlot.SQL 52 import Databrary.Model.Format.Types 53 import Databrary.Model.Format (getFormat') 54 import Databrary.Model.PermissionUtil (maskRestrictedString) 55 56 lookupAssetSlot :: (MonadHasIdentity c m, MonadDB c m) => Id Asset -> m (Maybe AssetSlot) 57 lookupAssetSlot ai = do 58 ident <- peek 59 dbQuery1 $(selectQuery (selectAssetSlot 'ident) "$WHERE asset.id = ${ai}") 60 61 lookupOrigAssetSlot :: (MonadHasIdentity c m, MonadDB c m) => Id Asset -> m (Maybe AssetSlot) 62 lookupOrigAssetSlot ai = do 63 initAsset <- lookupAssetSlot ai 64 let format = formatName . assetFormat . assetRow . slotAsset $ fromJust initAsset 65 case format of 66 ".pdf" -> lookupAssetSlot ai --TODO format name should support all doc types 67 _ -> do 68 ident <- peek 69 dbQuery1 $(selectQuery (selectAssetSlot 'ident) "$left join transcode tc on tc.orig = asset.id WHERE tc.asset = ${ai}") 70 71 lookupAssetAssetSlot :: (MonadDB c m) => Asset -> m AssetSlot 72 lookupAssetAssetSlot a = fromMaybe assetNoSlot 73 <$> dbQuery1 $(selectQuery selectAssetSlotAsset "$WHERE slot_asset.asset = ${assetId $ assetRow a} AND container.volume = ${volumeId $ volumeRow $ assetVolume a}") 74 <*> return a 75 76 lookupSlotAssets :: (MonadDB c m) => Slot -> m [AssetSlot] 77 lookupSlotAssets (Slot c s) = 78 dbQuery $ ($ c) <$> $(selectQuery selectContainerSlotAsset "$WHERE slot_asset.container = ${containerId $ containerRow c} AND slot_asset.segment && ${s} AND asset.volume = ${volumeId $ volumeRow $ containerVolume c}") 79 80 lookupOrigSlotAssets :: (MonadDB c m) => Slot -> m [AssetSlot] 81 lookupOrigSlotAssets slot@(Slot c _) = do 82 let _tenv_ablno = unknownPGTypeEnv 83 xs <- dbQuery {- [pgSQL| 84 SELECT asset.id,asset.format,output_asset.release,asset.duration,asset.name,asset.sha1,asset.size 85 FROM slot_asset 86 INNER JOIN transcode ON slot_asset.asset = transcode.asset 87 INNER JOIN asset ON transcode.orig = asset.id 88 INNER JOIN asset output_asset ON transcode.asset = output_asset.id 89 WHERE slot_asset.container = ${containerId $ containerRow c} 90 |] -} 91 (mapQuery2 92 ((\ _p_ablnp -> 93 (Data.ByteString.concat 94 [fromString 95 "\n\ 96 \ SELECT asset.id,asset.format,output_asset.release,asset.duration,asset.name,asset.sha1,asset.size \n\ 97 \ FROM slot_asset \n\ 98 \ INNER JOIN transcode ON slot_asset.asset = transcode.asset\n\ 99 \ INNER JOIN asset ON transcode.orig = asset.id\n\ 100 \ INNER JOIN asset output_asset ON transcode.asset = output_asset.id\n\ 101 \ WHERE slot_asset.container = ", 102 pgEscapeParameter 103 _tenv_ablno (PGTypeProxy :: PGTypeName "integer") _p_ablnp, 104 fromString 105 "\n\ 106 \ "])) 107 (containerId $ containerRow c)) 108 (\ 109 [_cid_ablnq, 110 _cformat_ablnr, 111 _crelease_ablns, 112 _cduration_ablnt, 113 _cname_ablnu, 114 _csha1_ablnv, 115 _csize_ablnw] 116 -> (pgDecodeColumnNotNull 117 _tenv_ablno (PGTypeProxy :: PGTypeName "integer") _cid_ablnq, 118 pgDecodeColumnNotNull 119 _tenv_ablno (PGTypeProxy :: PGTypeName "smallint") _cformat_ablnr, 120 pgDecodeColumn 121 _tenv_ablno (PGTypeProxy :: PGTypeName "release") _crelease_ablns, 122 pgDecodeColumn 123 _tenv_ablno 124 (PGTypeProxy :: PGTypeName "interval") 125 _cduration_ablnt, 126 pgDecodeColumn 127 _tenv_ablno (PGTypeProxy :: PGTypeName "text") _cname_ablnu, 128 pgDecodeColumn 129 _tenv_ablno (PGTypeProxy :: PGTypeName "bytea") _csha1_ablnv, 130 pgDecodeColumn 131 _tenv_ablno (PGTypeProxy :: PGTypeName "bigint") _csize_ablnw))) 132 return $ flip fmap xs $ \(assetId,formatId,release,duration,name,sha1,size) -> 133 -- this format value is only used to differentiate between audio/video or not 134 -- so it is okay that it is hardcoded to mp4, under the assumption that everything with an original 135 -- was an audio/video file that went through transcoding 136 let format = getFormat' formatId 137 -- Format (Id (-800)) "video/mp4" [] "" {-fromJust . getFormatByExtension $ encodeUtf8 $ fromJust name-} 138 assetRow = AssetRow (Id assetId) format release duration name sha1 size 139 in AssetSlot (Asset assetRow (containerVolume c)) (Just slot) 140 141 lookupContainerAssets :: (MonadDB c m) => Container -> m [AssetSlot] 142 lookupContainerAssets = lookupSlotAssets . containerSlot 143 144 lookupOrigContainerAssets :: (MonadDB c m) => Container -> m [AssetSlot] 145 lookupOrigContainerAssets = lookupOrigSlotAssets . containerSlot 146 147 lookupVolumeAssetSlots :: (MonadDB c m) => Volume -> Bool -> m [AssetSlot] 148 lookupVolumeAssetSlots v top = 149 dbQuery $ ($ v) <$> $(selectQuery selectVolumeSlotAsset "$WHERE asset.volume = ${volumeId $ volumeRow v} AND (container.top OR ${not top}) ORDER BY container.id") 150 151 {- lookupOrigVolumeAssetSlots :: (MonadDB c m, MonadHasIdentity c m) => Volume -> Bool -> m [AssetSlot] 152 lookupOrigVolumeAssetSlots v top = do 153 fromVol <- lookupVolumeAssetSlots v top 154 lookupOrigVolumeAssetSlots' fromVol -} 155 156 lookupOrigVolumeAssetSlots' :: (MonadDB c m, MonadHasIdentity c m) => [AssetSlot] -> m [AssetSlot] 157 lookupOrigVolumeAssetSlots' slotList = do 158 catMaybes <$> mapM originFinder slotList 159 where 160 originFinder (AssetSlot { slotAsset = Asset {assetRow = AssetRow { assetId = aid }}}) = lookupOrigAssetSlot aid 161 162 lookupVolumeAssetSlotIds :: (MonadDB c m) => Volume -> m [(Asset, SlotId)] 163 lookupVolumeAssetSlotIds v = 164 dbQuery $ ($ v) <$> $(selectQuery selectVolumeSlotIdAsset "$WHERE asset.volume = ${volumeId $ volumeRow v} ORDER BY container") 165 166 {- lookupOrigVolumeAssetSlotIds :: (MonadDB c m) => Volume -> m [(Asset, SlotId)] 167 lookupOrigVolumeAssetSlotIds v = 168 dbQuery $ ($ v) <$> $(selectQuery selectVolumeSlotIdAsset "$left join asset_revision ar on ar.orig = asset.id WHERE asset.volume = ${volumeId $ volumeRow v} ORDER BY container") -} 169 170 changeAssetSlot :: (MonadAudit c m) => AssetSlot -> m Bool 171 changeAssetSlot as = do 172 ident <- getAuditIdentity 173 let _tenv_a8II3 = unknownPGTypeEnv 174 if isNothing (assetSlot as) 175 then dbExecute1 -- (deleteSlotAsset 'ident 'as) 176 (mapQuery2 177 ((\ _p_a8II4 _p_a8II5 _p_a8II6 -> 178 (Data.ByteString.concat 179 [Data.String.fromString 180 "WITH audit_row AS (DELETE FROM slot_asset WHERE asset=", 181 Database.PostgreSQL.Typed.Types.pgEscapeParameter 182 _tenv_a8II3 183 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 184 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 185 _p_a8II4, 186 Data.String.fromString 187 " RETURNING *) INSERT INTO audit.slot_asset SELECT CURRENT_TIMESTAMP, ", 188 Database.PostgreSQL.Typed.Types.pgEscapeParameter 189 _tenv_a8II3 190 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 191 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 192 _p_a8II5, 193 Data.String.fromString ", ", 194 Database.PostgreSQL.Typed.Types.pgEscapeParameter 195 _tenv_a8II3 196 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 197 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 198 _p_a8II6, 199 Data.String.fromString 200 ", 'remove'::audit.action, * FROM audit_row"])) 201 (assetId $ assetRow $ slotAsset as) 202 (auditWho ident) 203 (auditIp ident)) 204 (\ [] -> ())) 205 else do 206 let _tenv_a8IMD = unknownPGTypeEnv 207 _tenv_a8IPn = unknownPGTypeEnv 208 (r, _) <- updateOrInsert 209 -- (updateSlotAsset 'ident 'as) 210 (mapQuery2 211 ((\ _p_a8IME _p_a8IMF _p_a8IMG _p_a8IMH _p_a8IMI -> 212 (Data.ByteString.concat 213 [Data.String.fromString 214 "WITH audit_row AS (UPDATE slot_asset SET container=", 215 Database.PostgreSQL.Typed.Types.pgEscapeParameter 216 _tenv_a8IMD 217 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 218 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 219 _p_a8IME, 220 Data.String.fromString ",segment=", 221 Database.PostgreSQL.Typed.Types.pgEscapeParameter 222 _tenv_a8IMD 223 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 224 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 225 _p_a8IMF, 226 Data.String.fromString " WHERE asset=", 227 Database.PostgreSQL.Typed.Types.pgEscapeParameter 228 _tenv_a8IMD 229 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 230 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 231 _p_a8IMG, 232 Data.String.fromString 233 " RETURNING *) INSERT INTO audit.slot_asset SELECT CURRENT_TIMESTAMP, ", 234 Database.PostgreSQL.Typed.Types.pgEscapeParameter 235 _tenv_a8IMD 236 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 237 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 238 _p_a8IMH, 239 Data.String.fromString ", ", 240 Database.PostgreSQL.Typed.Types.pgEscapeParameter 241 _tenv_a8IMD 242 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 243 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 244 _p_a8IMI, 245 Data.String.fromString 246 ", 'change'::audit.action, * FROM audit_row"])) 247 (containerId . containerRow . slotContainer <$> assetSlot as) 248 (slotSegment <$> assetSlot as) 249 (assetId $ assetRow $ slotAsset as) 250 (auditWho ident) 251 (auditIp ident)) 252 (\[] -> ())) 253 -- (insertSlotAsset 'ident 'as) 254 (mapQuery2 255 ((\ _p_a8IPo _p_a8IPp _p_a8IPq _p_a8IPr _p_a8IPs -> 256 (Data.ByteString.concat 257 [Data.String.fromString 258 "WITH audit_row AS (INSERT INTO slot_asset (asset,container,segment) VALUES (", 259 Database.PostgreSQL.Typed.Types.pgEscapeParameter 260 _tenv_a8IPn 261 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 262 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 263 _p_a8IPo, 264 Data.String.fromString ",", 265 Database.PostgreSQL.Typed.Types.pgEscapeParameter 266 _tenv_a8IPn 267 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 268 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 269 _p_a8IPp, 270 Data.String.fromString ",", 271 Database.PostgreSQL.Typed.Types.pgEscapeParameter 272 _tenv_a8IPn 273 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 274 Database.PostgreSQL.Typed.Types.PGTypeName "segment") 275 _p_a8IPq, 276 Data.String.fromString 277 ") RETURNING *) INSERT INTO audit.slot_asset SELECT CURRENT_TIMESTAMP, ", 278 Database.PostgreSQL.Typed.Types.pgEscapeParameter 279 _tenv_a8IPn 280 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 281 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 282 _p_a8IPr, 283 Data.String.fromString ", ", 284 Database.PostgreSQL.Typed.Types.pgEscapeParameter 285 _tenv_a8IPn 286 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 287 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 288 _p_a8IPs, 289 Data.String.fromString ", 'add'::audit.action, * FROM audit_row"])) 290 (assetId $ assetRow $ slotAsset as) 291 (containerId . containerRow . slotContainer <$> assetSlot as) 292 (slotSegment <$> assetSlot as) 293 (auditWho ident) 294 (auditIp ident)) 295 (\[] -> ())) 296 when (r /= 1) $ fail $ "changeAssetSlot: " ++ show r ++ " rows" 297 return True 298 299 changeAssetSlotDuration :: MonadDB c m => Asset -> m Bool 300 changeAssetSlotDuration a 301 | Just dur <- assetDuration $ assetRow a = do 302 let _tenv_ablLj = unknownPGTypeEnv 303 dbExecute1 -- [pgSQL|UPDATE slot_asset SET segment = segment(lower(segment), lower(segment) + ${dur}) WHERE asset = ${assetId $ assetRow a}|] 304 (mapQuery2 305 ((\ _p_ablLk _p_ablLl -> 306 (Data.ByteString.concat 307 [fromString 308 "UPDATE slot_asset SET segment = segment(lower(segment), lower(segment) + ", 309 pgEscapeParameter 310 _tenv_ablLj (PGTypeProxy :: PGTypeName "interval") _p_ablLk, 311 fromString ") WHERE asset = ", 312 pgEscapeParameter 313 _tenv_ablLj (PGTypeProxy :: PGTypeName "integer") _p_ablLl])) 314 dur (assetId $ assetRow a)) 315 (\[] -> ())) 316 | otherwise = return False 317 318 fixAssetSlotDuration :: AssetSlot -> AssetSlot 319 fixAssetSlotDuration as 320 | Just dur <- assetDuration $ assetRow $ slotAsset as = as{ assetSlot = (\s -> s{ slotSegment = segmentSetDuration dur (slotSegment s) }) <$> assetSlot as } 321 | otherwise = as 322 323 findAssetContainerEnd :: MonadDB c m => Container -> m Offset 324 findAssetContainerEnd c = do 325 let _tenv_ablQT = unknownPGTypeEnv 326 fromMaybe 0 <$> 327 dbQuery1' -- [pgSQL|SELECT max(upper(segment))+'1s' FROM slot_asset WHERE container = ${containerId $ containerRow c}|] 328 (mapQuery2 329 ((\ _p_ablQU -> 330 (Data.ByteString.concat 331 [fromString 332 "SELECT max(upper(segment))+'1s' FROM slot_asset WHERE container = ", 333 pgEscapeParameter 334 _tenv_ablQT (PGTypeProxy :: PGTypeName "integer") _p_ablQU])) 335 (containerId $ containerRow c)) 336 (\[_ccolumn_ablQV] 337 -> (pgDecodeColumn 338 _tenv_ablQT 339 (PGTypeProxy :: PGTypeName "interval") 340 _ccolumn_ablQV))) 341 342 assetSlotName :: AssetSlot -> Maybe T.Text 343 assetSlotName a = 344 guard 345 (any (containerTop . containerRow . slotContainer) (assetSlot a) 346 || canReadData2 getAssetSlotRelease2 getAssetSlotVolumePermission2 a) 347 >> assetName (assetRow $ slotAsset a) 348 349 assetSlotJSON :: JSON.ToObject o => Bool -> AssetSlot -> JSON.Record (Id Asset) o 350 assetSlotJSON publicRestricted as@AssetSlot{..} = assetJSON publicRestricted slotAsset `JSON.foldObjectIntoRec` 351 (foldMap (segmentJSON . slotSegment) assetSlot 352 -- "release" `JSON.kvObjectOrEmpty` (view as :: Maybe Release) 353 <> "name" `JSON.kvObjectOrEmpty` (if publicRestricted then fmap maskRestrictedString (assetSlotName as) else assetSlotName as) 354 <> "permission" JSON..= p 355 <> "size" `JSON.kvObjectOrEmpty` (z `useWhen` (p > PermissionNONE && any (0 <=) z))) 356 where 357 p = dataPermission4 getAssetSlotRelease2 getAssetSlotVolumePermission2 as 358 z = assetSize $ assetRow slotAsset 359 360 {- 361 assetSlotJSONRestricted :: JSON.ToObject o => AssetSlot -> JSON.Record (Id Asset) o 362 assetSlotJSONRestricted as@AssetSlot{..} = assetJSONRestricted slotAsset JSON..<> 363 foldMap (segmentJSON . slotSegment) assetSlot 364 -- "release" `JSON.kvObjectOrEmpty` (view as :: Maybe Release) 365 <> "name" `JSON.kvObjectOrEmpty` (fmap maskRestrictedString (assetSlotName as)) 366 <> "permission" JSON..= p 367 <> "size" `JSON.kvObjectOrEmpty` (z <? p > PermissionNONE && any (0 <=) z) 368 where 369 p = dataPermission as 370 z = assetSize $ assetRow slotAsset 371 -}