1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-}
    2 module Model.Excerpt
    3   ( lookupAssetExcerpts
    4   , lookupSlotExcerpts
    5   , lookupVolumeExcerpts
    6   , lookupSlotThumb
    7   , lookupVolumeThumb
    8   , changeExcerpt
    9   , removeExcerpt
   10   , excerptJSON
   11   ) where
   12 
   13 import Control.Monad (guard)
   14 
   15 import Has (view)
   16 import qualified JSON
   17 import Service.DB
   18 import Model.SQL
   19 import Model.Permission
   20 import Model.Audit
   21 import Model.Volume.Types
   22 import Model.Container.Types
   23 import Model.Slot.Types
   24 import Model.Asset.Types
   25 import Model.AssetSlot.Types
   26 import Model.AssetSegment
   27 import Model.Excerpt.SQL
   28 
   29 lookupAssetExcerpts :: MonadDB c m => AssetSlot -> m [Excerpt]
   30 lookupAssetExcerpts a =
   31   dbQuery $ ($ a) <$> $(selectQuery selectAssetSlotExcerpt "$WHERE excerpt.asset = ${assetId $ assetRow $ slotAsset a}")
   32 
   33 lookupSlotExcerpts :: MonadDB c m => Slot -> m [Excerpt]
   34 lookupSlotExcerpts (Slot c s) =
   35   dbQuery $ ($ c) <$> $(selectQuery selectContainerExcerpt "$WHERE slot_asset.container = ${containerId $ containerRow c} AND excerpt.segment && ${s}")
   36 
   37 lookupVolumeExcerpts :: MonadDB c m => Volume -> m [Excerpt]
   38 lookupVolumeExcerpts v =
   39   dbQuery $ ($ v) <$> $(selectQuery selectVolumeExcerpt "$WHERE asset.volume = ${volumeId $ volumeRow v}")
   40 
   41 lookupSlotThumb :: MonadDB c m => Slot -> m (Maybe AssetSegment)
   42 lookupSlotThumb (Slot c s) =
   43   dbQuery1 $ assetSegmentInterp 0 . excerptAsset . ($ c) <$> $(selectQuery selectContainerExcerpt "$\
   44     \JOIN format ON asset.format = format.id \
   45     \WHERE slot_asset.container = ${containerId $ containerRow c} AND excerpt.segment && ${s} \
   46       \AND COALESCE(GREATEST(excerpt.release, asset.release), ${containerRelease c}) >= ${readRelease (view c)}::release \
   47       \AND (asset.duration IS NOT NULL AND format.mimetype LIKE 'video/%' OR format.mimetype LIKE 'image/%') \
   48       \AND asset.sha1 IS NOT NULL \
   49     \LIMIT 1")
   50 
   51 lookupVolumeThumb :: MonadDB c m => Volume -> m (Maybe AssetSegment)
   52 lookupVolumeThumb v =
   53   dbQuery1 $ assetSegmentInterp 0 . excerptAsset . ($ v) <$> $(selectQuery selectVolumeExcerpt "$\
   54     \JOIN format ON asset.format = format.id \
   55     \WHERE asset.volume = ${volumeId $ volumeRow v} \
   56       \AND COALESCE(GREATEST(excerpt.release, asset.release), slot_release.release) >= ${readRelease (view v)}::release \
   57       \AND (asset.duration IS NOT NULL AND format.mimetype LIKE 'video/%' OR format.mimetype LIKE 'image/%') \
   58       \AND asset.sha1 IS NOT NULL \
   59     \ORDER BY container.top DESC LIMIT 1")
   60 
   61 changeExcerpt :: MonadAudit c m => Excerpt -> m Bool
   62 changeExcerpt e = do
   63   ident <- getAuditIdentity
   64   either (const False) ((0 <) . fst) <$> tryUpdateOrInsert (guard . isExclusionViolation)
   65     $(updateExcerpt 'ident 'e)
   66     $(insertExcerpt 'ident 'e)
   67 
   68 removeExcerpt :: MonadAudit c m => AssetSegment -> m Bool
   69 removeExcerpt e = do
   70   ident <- getAuditIdentity
   71   dbExecute1 $(deleteExcerpt 'ident 'e)
   72 
   73 excerptJSON :: JSON.ToObject o => Excerpt -> o
   74 excerptJSON = assetSegmentJSON . excerptAsset