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