1 {-# LANGUAGE TemplateHaskell, QuasiQuotes, RecordWildCards, OverloadedStrings, ScopedTypeVariables, DataKinds #-}
    2 module Databrary.Model.AssetSegment
    3   ( module Databrary.Model.AssetSegment.Types
    4   , lookupAssetSegment
    5   , lookupSlotAssetSegment
    6   , lookupAssetSlotSegment
    7   , lookupOrigSlotAssetSegment
    8   , lookupSlotSegmentThumb
    9   , auditAssetSegmentDownload
   10   , assetSegmentJSON
   11   , assetSegmentInterp
   12   ) where
   13 
   14 import Control.Applicative (pure, empty)
   15 import Data.Monoid ((<>))
   16 import Database.PostgreSQL.Typed (pgSQL)
   17 import Database.PostgreSQL.Typed.Query
   18 import Database.PostgreSQL.Typed.Types
   19 import qualified Data.ByteString
   20 import Data.ByteString (ByteString)
   21 import qualified Data.String
   22 
   23 import Databrary.Ops
   24 import Databrary.Has (peek, view)
   25 import qualified Databrary.JSON as JSON
   26 import Databrary.Service.DB
   27 import Databrary.Model.SQL
   28 import Databrary.Model.Audit
   29 import Databrary.Model.Id
   30 import Databrary.Model.Party.Types
   31 import Databrary.Model.Identity
   32 import Databrary.Model.Permission
   33 import Databrary.Model.Segment
   34 import Databrary.Model.Volume.Types
   35 import Databrary.Model.Container.Types
   36 import Databrary.Model.Slot.Types
   37 import Databrary.Model.Format.Types
   38 import Databrary.Model.Asset.Types
   39 import Databrary.Model.AssetSlot
   40 import Databrary.Model.AssetSegment.Types
   41 import Databrary.Model.AssetSegment.SQL
   42 
   43 lookupAssetSegment :: (MonadHasIdentity c m, MonadDB c m) => Segment -> Id Asset -> m (Maybe AssetSegment)
   44 lookupAssetSegment seg ai = do
   45   ident :: Identity <- peek
   46   dbQuery1 $(selectQuery (selectAssetSegment 'ident 'seg) "$WHERE slot_asset.asset = ${ai} AND slot_asset.segment && ${seg}")
   47 
   48 lookupSlotAssetSegment :: (MonadHasIdentity c m, MonadDB c m) => Id Slot -> Id Asset -> m (Maybe AssetSegment)
   49 lookupSlotAssetSegment (Id (SlotId ci seg)) ai = do
   50   ident :: Identity <- peek
   51   dbQuery1 $(selectQuery (selectAssetSegment 'ident 'seg) 
   52     "$WHERE slot_asset.container = ${ci} AND slot_asset.asset = ${ai} AND slot_asset.segment && ${seg}")
   53 
   54 lookupOrigSlotAssetSegment :: (MonadHasIdentity c m, MonadDB c m) => Id Slot -> Id Asset -> m (Maybe AssetSegment)
   55 lookupOrigSlotAssetSegment (Id (SlotId ci seg)) ai = do
   56   ident :: Identity <- peek
   57   dbQuery1 $(selectQuery (selectAssetSegment 'ident 'seg) 
   58     "$inner join asset_revision ar on ar.asset = asset.id WHERE slot_asset.container = ${ci} AND slot_asset.asset = ${ai} AND slot_asset.segment && ${seg}")
   59 
   60 
   61 lookupAssetSlotSegment :: MonadDB c m => AssetSlot -> Segment -> m (Maybe AssetSegment)
   62 lookupAssetSlotSegment a s =
   63   (segmentEmpty seg) `unlessReturn` (as <$>
   64     dbQuery1 $(selectQuery excerptRow "$WHERE asset = ${view a :: Id Asset} AND segment @> ${seg}"))
   65   where
   66   as = makeExcerpt a s
   67   seg = assetSegment $ as Nothing
   68 
   69 lookupSlotSegmentThumb :: MonadDB c m => Slot -> m (Maybe AssetSegment)
   70 lookupSlotSegmentThumb (Slot c s) = do
   71   dbQuery1 $ assetSegmentInterp 0.25 . ($ c) <$> $(selectQuery (selectContainerAssetSegment 's) "$\
   72     \JOIN format ON asset.format = format.id \
   73     \WHERE slot_asset.container = ${containerId $ containerRow c} AND slot_asset.segment && ${s} \
   74       \AND COALESCE(asset.release, ${containerRelease c}) >= ${readRelease (view c)}::release \
   75       \AND (asset.duration IS NOT NULL AND format.mimetype LIKE 'video/%' OR format.mimetype LIKE 'image/%') \
   76     \LIMIT 1")
   77 
   78 mapQuery :: ByteString -> ([PGValue] -> a) -> PGSimpleQuery a
   79 mapQuery qry mkResult =
   80   fmap mkResult (rawPGSimpleQuery qry)
   81 
   82 auditAssetSegmentDownload :: MonadAudit c m => Bool -> AssetSegment -> m ()
   83 auditAssetSegmentDownload success AssetSegment{ segmentAsset = AssetSlot{ slotAsset = a, assetSlot = as }, assetSegment = seg } = do  
   84   ai <- getAuditIdentity
   85   let _tenv_a9v9T = unknownPGTypeEnv
   86   maybe
   87     (dbExecute1'
   88        {- [pgSQL|INSERT INTO audit.asset (audit_action, audit_user, audit_ip, id, volume, format, release) VALUES
   89            (${act}, ${auditWho ai}, ${auditIp ai}, ${assetId $ assetRow a}, ${volumeId $ volumeRow $ assetVolume a}, ${formatId $ assetFormat $ assetRow a}, ${assetRelease $ assetRow a})|] -}
   90       (mapQuery
   91           ((\ _p_a9v9U _p_a9v9V _p_a9v9W _p_a9v9X _p_a9v9Y _p_a9v9Z _p_a9va0 ->
   92                     (Data.ByteString.concat
   93                        [Data.String.fromString
   94                           "INSERT INTO audit.asset (audit_action, audit_user, audit_ip, id, volume, format, release) VALUES\n\
   95                           \      (",
   96                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
   97                           _tenv_a9v9T
   98                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   99                              Database.PostgreSQL.Typed.Types.PGTypeName "audit.action")
  100                           _p_a9v9U,
  101                         Data.String.fromString ", ",
  102                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  103                           _tenv_a9v9T
  104                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  105                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  106                           _p_a9v9V,
  107                         Data.String.fromString ", ",
  108                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  109                           _tenv_a9v9T
  110                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  111                              Database.PostgreSQL.Typed.Types.PGTypeName "inet")
  112                           _p_a9v9W,
  113                         Data.String.fromString ", ",
  114                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  115                           _tenv_a9v9T
  116                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  117                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  118                           _p_a9v9X,
  119                         Data.String.fromString ", ",
  120                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  121                           _tenv_a9v9T
  122                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  123                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  124                           _p_a9v9Y,
  125                         Data.String.fromString ", ",
  126                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  127                           _tenv_a9v9T
  128                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  129                              Database.PostgreSQL.Typed.Types.PGTypeName "smallint")
  130                           _p_a9v9Z,
  131                         Data.String.fromString ", ",
  132                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  133                           _tenv_a9v9T
  134                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  135                              Database.PostgreSQL.Typed.Types.PGTypeName "release")
  136                           _p_a9va0,
  137                         Data.String.fromString ")"]))
  138       act
  139       (auditWho ai)
  140       (auditIp ai)
  141       (assetId $ assetRow a)
  142       (volumeId $ volumeRow $ assetVolume a)
  143       (formatId $ assetFormat $ assetRow a)
  144       (assetRelease $ assetRow a))
  145             (\[] -> ())))
  146     (\s -> dbExecute1' [pgSQL|$INSERT INTO audit.slot_asset (audit_action, audit_user, audit_ip, container, segment, asset) VALUES
  147       (${act}, ${auditWho ai}, ${auditIp ai}, ${containerId $ containerRow $ slotContainer s}, ${seg}, ${assetId $ assetRow a})|])
  148     as
  149   where act | success = AuditActionOpen
  150             | otherwise = AuditActionAttempt
  151 
  152 assetSegmentJSON :: JSON.ToObject o => AssetSegment -> o
  153 assetSegmentJSON as@AssetSegment{..} =
  154      "segment" JSON..= assetSegment
  155   <> "format" `JSON.kvObjectOrEmpty` (if view segmentAsset == fmt then empty else pure (formatId fmt))
  156   -- "release" `JSON.kvObjectOrEmpty` (view as :: Maybe Release)
  157   <> "permission" JSON..= dataPermission4 getAssetSegmentRelease2 getAssetSegmentVolumePermission2 as
  158   <> "excerpt" `JSON.kvObjectOrEmpty` (excerptRelease <$> assetExcerpt)
  159   where fmt = view as
  160 
  161 assetSegmentInterp :: Float -> AssetSegment -> AssetSegment
  162 assetSegmentInterp f as = as{ assetSegment = segmentInterp f $ assetSegment as }