1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-}
    2 module Databrary.Model.Activity
    3   ( lookupPartyActivity
    4   , lookupVolumeActivity
    5   , lookupContainerActivity
    6   , activityJSON
    7   , mergeBy
    8   ) where
    9 
   10 import Control.Applicative ((<|>), empty, pure)
   11 import Control.Arrow ((&&&))
   12 import Control.Monad (forM)
   13 import qualified Data.ByteString.Char8 as BSC
   14 import Data.Function (on)
   15 import qualified Data.HashMap.Strict as HM
   16 import Data.List (foldl')
   17 import qualified Data.Map as Map
   18 import Data.Monoid ((<>))
   19 import qualified Data.Text as T
   20 import Data.Time.Clock (diffUTCTime)
   21 
   22 import Databrary.Ops
   23 import Databrary.Has
   24 import qualified Databrary.JSON as JSON
   25 import Databrary.Service.DB
   26 import Databrary.Model.SQL
   27 import Databrary.Model.Identity
   28 import Databrary.Model.Id
   29 import Databrary.Model.Time
   30 import Databrary.Model.Audit
   31 import Databrary.Model.Volume
   32 import Databrary.Model.VolumeAccess
   33 import Databrary.Model.Party
   34 import Databrary.Model.Authorize
   35 import Databrary.Model.Container
   36 import Databrary.Model.Segment
   37 import Databrary.Model.Slot
   38 import Databrary.Model.Asset
   39 import Databrary.Model.AssetRevision
   40 import Databrary.Model.Activity.Types
   41 import Databrary.Model.Activity.SQL
   42 
   43 onActivityTime :: (Timestamp -> Timestamp -> a) -> Activity -> Activity -> a
   44 onActivityTime = (`on` auditWhen . activityAudit)
   45 
   46 orderActivity :: Activity -> Activity -> Ordering
   47 orderActivity = onActivityTime compare
   48 
   49 mergeActivity :: [Activity] -> [Activity] -> [Activity]
   50 mergeActivity = mergeBy $ \x y -> orderActivity x y <> LT
   51 
   52 mergeActivities :: [[Activity]] -> [Activity]
   53 mergeActivities = foldr1 mergeActivity
   54 
   55 joinActivitiesWith :: (Activity -> Maybe (Activity -> Maybe Activity)) -> [Activity] -> [Activity]
   56 joinActivitiesWith f (a1:a1r) = maybe al
   57   (\af ->
   58     let la c (a2:a2r)
   59           | onActivityTime diffUTCTime a2 a1 >= 1 = al
   60           | ((==) `on` auditIdentity . activityAudit) a1 a2, Just a <- af a2 = a : joinActivitiesWith f (c a2r)
   61           | otherwise = la (c . (a2 :)) a2r
   62         la c [] = a1 : joinActivitiesWith f (c [])
   63     in la id a1r)
   64   $ f a1
   65   where al = a1 : joinActivitiesWith f a1r
   66 joinActivitiesWith _ [] = []
   67 
   68 chainPrev :: Ord a => (ActivityTarget -> a) -> [Activity] -> [Activity]
   69 chainPrev f = scan Map.empty where
   70   scan m (a@Activity{ activityAudit = Audit{ auditAction = act }, activityTarget = t }:l) = a{ activityPrev = p } : scan m' l where
   71     (p, m') = case act of
   72       AuditActionAdd -> (Nothing, Map.insert (f t) t m)
   73       AuditActionRemove -> Map.updateLookupWithKey (\_ _ -> Nothing) (f t) m
   74       AuditActionChange -> Map.insertLookupWithKey (const const) (f t) t m
   75       _ -> (activityPrev a, m)
   76   scan _ [] = []
   77 
   78 maskPasswords :: [Activity] -> [Activity]
   79 maskPasswords = mp HM.empty (0 :: Integer) where
   80   -- this could be done much more simply since passwords are never going to repeat in practice
   81   mp m c (a@Activity{ activityTarget = at@ActivityAccount{ activityAccountPassword = Just p } }:l)
   82     | Just i <- HM.lookup p m = f i : mp m c l
   83     | otherwise = f c : mp (HM.insert p c m) (succ c) l
   84     where f i = a{ activityTarget = at{ activityAccountPassword = Just $ BSC.pack $ show i } }
   85   mp m c (a:l) = a : mp m c l
   86   mp _ _ [] = []
   87 
   88 lookupPartyActivity :: (MonadDB c m, MonadHasIdentity c m) => Party -> m [Activity]
   89 lookupPartyActivity p = do
   90   ident <- peek
   91   pa <- chainPrev (const ())
   92     <$> dbQuery $(selectQuery selectActivityParty $ "WHERE party.id = ${partyId $ partyRow p} AND " ++ activityQual)
   93   ca <- chainPrev (const ()) . maskPasswords
   94     <$> dbQuery $(selectQuery selectActivityAccount $ "WHERE account.id = ${partyId $ partyRow p} ORDER BY audit_time") -- unqual: include logins
   95   aa <- chainPrev (partyId . partyRow . authorizeChild . authorization . activityAuthorize)
   96     <$> dbQuery $(selectQuery (selectActivityAuthorize 'p 'ident) $ "WHERE " ++ activityQual)
   97   return $ mergeActivities [pa, ca, aa]
   98 
   99 lookupVolumeActivity :: (MonadDB c m, MonadHasIdentity c m) => Volume -> m [Activity]
  100 lookupVolumeActivity vol = do
  101   ident <- peek
  102   va <- chainPrev (const ())
  103     <$> dbQuery $(selectQuery selectActivityVolume $ "!WHERE volume.id = ${volumeId $ volumeRow vol} AND " ++ activityQual)
  104   aa <- chainPrev (partyId . partyRow . volumeAccessParty . activityAccess)
  105     <$> dbQuery $(selectQuery (selectActivityAccess 'vol 'ident) $ "WHERE " ++ activityQual)
  106   return $ mergeActivities [va, aa]
  107 
  108 addAssetRevision :: (MonadDB c m, MonadHasIdentity c m) => Volume -> Activity -> m Activity
  109 addAssetRevision vol
  110   act@Activity{ activityAudit = Audit{ auditAction = aa }, activityTarget = ActivityAssetSlot{ activityAssetId = ai }, activityPrev = Nothing }
  111   | aa <= AuditActionChange = do
  112     ar <- if aa == AuditActionChange then lookupAssetReplace a else return Nothing
  113     at <- lookupAssetTranscode a
  114     return act
  115       { activityReplace = revisionOrig <$> ar
  116       , activityTranscode = revisionOrig <$> at
  117       }
  118     where
  119     a = ba{ assetRow = (assetRow ba){ assetId = ai } }
  120     ba = blankAsset vol
  121 addAssetRevision _ a = return a
  122 
  123 mergeAssetCreation :: [Activity] -> [Activity]
  124 mergeAssetCreation = joinActivitiesWith f1 where
  125   f1 a@Activity{ activityAudit = Audit{ auditAction = AuditActionAdd  }, activityTarget = ActivityAsset aa, activityPrev = Nothing } = Just f2 where
  126     f2 Activity{ activityAudit = Audit{ auditAction = AuditActionChange }, activityTarget = ActivityAsset ac, activityPrev = Just (ActivityAsset aa') }
  127       | assetId aa == assetId aa' = Just a{ activityTarget = ActivityAsset ac, activityPrev = Just (ActivityAsset aa) }
  128     f2 _ = Nothing
  129   f1 _ = Nothing
  130 
  131 mergeActivityAssetAndSlot :: ActivityTarget -> ActivityTarget -> Maybe ActivityTarget
  132 mergeActivityAssetAndSlot (ActivityAsset ar) (ActivityAssetSlot ai si) =
  133   (assetId ar == ai) `thenUse` (ActivityAssetAndSlot ar si)
  134 mergeActivityAssetAndSlot _ _ = Nothing
  135 
  136 mergeAssetAndSlot :: [Activity] -> [Activity]
  137 mergeAssetAndSlot = joinActivitiesWith f1 where
  138   f1 Activity{ activityAudit = a1, activityTarget = t1, activityPrev = p1, activityReplace = Nothing, activityTranscode = Nothing } = Just f2 where
  139     f2 a@Activity{ activityAudit = a2, activityTarget = t2, activityPrev = p2 }
  140       | auditAction a1 <= auditAction a2 && auditAction a2 <= AuditActionChange
  141       , Just t <- mergeActivityAssetAndSlot t1 t2 = Just a
  142         { activityAudit = a1
  143         , activityTarget = t
  144         , activityPrev = (do
  145           p1t <- p1
  146           mergeActivityAssetAndSlot p1t =<< p2) <|> p1 <|> p2
  147         }
  148     f2 _ = Nothing
  149   f1 _ = Nothing
  150 
  151 lookupContainerActivity :: (MonadDB c m, MonadHasIdentity c m) => Container -> m [Activity]
  152 lookupContainerActivity cont = do
  153   ca <- chainPrev (const ())
  154     <$> dbQuery $(selectQuery selectActivityContainer $ "WHERE container.id = ${containerId $ containerRow cont} AND " ++ activityQual)
  155   ra <- chainPrev (slotSegmentId . activitySlotId)
  156     <$> dbQuery $(selectQuery selectActivityRelease $ "WHERE slot_release.container = ${containerId $ containerRow cont} AND " ++ activityQual)
  157 
  158   asa <- mapM (addAssetRevision (containerVolume cont)) =<< chainPrev activityAssetId
  159     <$> dbQuery $(selectQuery selectActivityAssetSlot $ "WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)
  160 
  161   caa <- mergeAssetCreation . chainPrev (assetId . activityAssetRow)
  162     <$> dbQuery $(selectQuery selectActivityAsset $ "JOIN slot_asset ON asset.id = slot_asset.asset WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)
  163   let uam m Activity{ activityAudit = Audit{ auditAction = AuditActionRemove, auditWhen = t }, activityTarget = ActivityAssetSlot{ activityAssetId = a } } =
  164         Map.insert a t m
  165       uam m Activity{ activityAudit = Audit{ auditAction = AuditActionChange, auditWhen = t }, activityReplace = Just ar } =
  166         Map.insert (assetId $ assetRow ar) t m
  167       uam m _ = m
  168       dam = flip $ Map.delete . assetId . activityAssetRow . activityTarget
  169       oal = Map.toList $ foldl' dam (foldl' uam Map.empty asa) caa
  170   oaa <- forM oal $ \(ai, at) ->
  171     mergeAssetCreation . chainPrev (const ())
  172       <$> dbQuery $(selectQuery selectActivityAsset $ "WHERE asset.id = ${ai} AND audit_time <= ${at} AND " ++ activityQual)
  173 
  174   cea <- chainPrev (activityAssetId &&& activitySegment)
  175     <$> dbQuery $(selectQuery selectActivityExcerpt $ "JOIN slot_asset ON excerpt.asset = slot_asset.asset WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)
  176 
  177   return $ mergeAssetAndSlot $ mergeActivities (ca:ra:asa:cea:caa:oaa)
  178 
  179 -- EDIT permission assumed for all
  180 activityTargetJSON :: ActivityTarget -> (T.Text, JSON.Object, JSON.Object)
  181 activityTargetJSON (ActivityParty p) =
  182   ("party", mempty, JSON.recordObject $
  183     partyRowJSON p)
  184 activityTargetJSON ActivityAccount{..} =
  185   ("account", mempty,
  186     "email" JSON..= activityAccountEmail <> "password" JSON..= activityAccountPassword)
  187 activityTargetJSON (ActivityAuthorize a) =
  188   ("authorize", "party" JSON..=: partyJSON (authorizeChild $ authorization a),
  189     authorizeJSON a)
  190 activityTargetJSON (ActivityVolume v) =
  191   ("volume", mempty, JSON.recordObject $
  192     volumeRowJSON v `JSON.foldObjectIntoRec`
  193       ("alias" `JSON.kvObjectOrEmpty` volumeAlias v))
  194 activityTargetJSON (ActivityAccess a) =
  195   ("access", "party" JSON..=: partyJSON (volumeAccessParty a),
  196     volumeAccessJSON a)
  197 activityTargetJSON (ActivityContainer c) =
  198   ("container", mempty, JSON.recordObject $
  199     containerRowJSON False c `JSON.foldObjectIntoRec` -- False assumes edit level on volume for activity route
  200       ("date" `JSON.kvObjectOrEmpty` containerDate c))
  201 activityTargetJSON ActivityRelease{..} =
  202   ("release", segmentJSON $ slotSegmentId activitySlotId,
  203     "release" JSON..= activityRelease)
  204 activityTargetJSON (ActivityAsset a) =
  205   ("asset", "id" JSON..= assetId a,
  206     "classification" `JSON.kvObjectOrEmpty` assetRelease a <> "name" `JSON.kvObjectOrEmpty` assetName a)
  207 activityTargetJSON (ActivityAssetSlot a s) =
  208   ("asset", "id" JSON..= a,
  209     segmentJSON $ slotSegmentId s)
  210 activityTargetJSON (ActivityAssetAndSlot a s) = (n, i, o <> segmentJSON (slotSegmentId s)) where
  211   (n, i, o) = activityTargetJSON (ActivityAsset a)
  212 activityTargetJSON ActivityExcerpt{..} =
  213   ("excerpt", "id" JSON..= activityAssetId <> segmentJSON activitySegment,
  214     "excerpt" `JSON.kvObjectOrEmpty` activityExcerptRelease)
  215 
  216 activityAssetJSON :: Asset -> JSON.Object
  217 activityAssetJSON a =
  218   JSON.recordObject $ assetJSON False a
  219       `JSON.foldObjectIntoRec` ("name" `JSON.kvObjectOrEmpty` assetName (assetRow a)) -- False assumes edit
  220 
  221 activityJSON :: Activity -> Maybe JSON.Object
  222 activityJSON Activity{ activityAudit = Audit{..}, ..} = (auditAction == AuditActionChange && HM.null new && HM.null old) `unlessUse`
  223   (new <> key
  224     <> "when" JSON..= auditWhen
  225     <> "action" JSON..= show (auditAction)
  226     <> "ip" JSON..= show (auditIp auditIdentity)
  227     <> "user" JSON..= auditWho auditIdentity
  228     <> "type" JSON..= typ
  229     <> "old" `JSON.kvObjectOrEmpty` (if HM.null old then empty else pure old)
  230     <> "replace" `JSON.kvObjectOrEmpty` (activityAssetJSON <$> activityReplace)
  231     <> "transcode" `JSON.kvObjectOrEmpty` (activityAssetJSON <$> activityTranscode))
  232   where
  233   (new, old)
  234     | auditAction == AuditActionRemove
  235       = (HM.empty, targ)
  236     | Just p <- activityPrev
  237     , (_, _, prev) <- activityTargetJSON p
  238     , int <- HM.filter id $ HM.intersectionWith (==) targ prev
  239       = (if auditAction == AuditActionAdd then targ else HM.difference targ int, HM.difference prev int)
  240     | otherwise
  241       = (targ, HM.empty)
  242   (typ, key, targ) = activityTargetJSON activityTarget