{-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-}
module Model.Activity
  ( lookupPartyActivity
  , lookupVolumeActivity
  , lookupContainerActivity
  , activityJSON
  , mergeBy
  ) where

import Control.Applicative ((<|>), empty, pure)
import Control.Arrow ((&&&))
import Control.Monad (forM)
import qualified Data.ByteString.Char8 as BSC
import Data.Function (on)
import qualified Data.HashMap.Strict as HM
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Time.Clock (diffUTCTime)

import Ops
import Has
import qualified JSON
import Service.DB
import Model.SQL
import Model.Identity
import Model.Id
import Model.Time
import Model.Audit
import Model.Volume
import Model.VolumeAccess
import Model.Party
import Model.Authorize
import Model.Container
import Model.Segment
import Model.Slot
import Model.Asset
import Model.AssetRevision
import Model.Activity.Types
import Model.Activity.SQL

onActivityTime :: (Timestamp -> Timestamp -> a) -> Activity -> Activity -> a
onActivityTime = (`on` auditWhen . activityAudit)

orderActivity :: Activity -> Activity -> Ordering
orderActivity = onActivityTime compare

mergeActivity :: [Activity] -> [Activity] -> [Activity]
mergeActivity = mergeBy $ \x y -> orderActivity x y <> LT

mergeActivities :: [[Activity]] -> [Activity]
mergeActivities = foldr1 mergeActivity

joinActivitiesWith :: (Activity -> Maybe (Activity -> Maybe Activity)) -> [Activity] -> [Activity]
joinActivitiesWith f (a1:a1r) = maybe al
  (\af ->
    let la c (a2:a2r)
          | onActivityTime diffUTCTime a2 a1 >= 1 = al
          | ((==) `on` auditIdentity . activityAudit) a1 a2, Just a <- af a2 = a : joinActivitiesWith f (c a2r)
          | otherwise = la (c . (a2 :)) a2r
        la c [] = a1 : joinActivitiesWith f (c [])
    in la id a1r)
  $ f a1
  where al = a1 : joinActivitiesWith f a1r
joinActivitiesWith _ [] = []

chainPrev :: Ord a => (ActivityTarget -> a) -> [Activity] -> [Activity]
chainPrev f = scan Map.empty where
  scan m (a@Activity{ activityAudit = Audit{ auditAction = act }, activityTarget = t }:l) = a{ activityPrev = p } : scan m' l where
    (p, m') = case act of
      AuditActionAdd -> (Nothing, Map.insert (f t) t m)
      AuditActionRemove -> Map.updateLookupWithKey (\_ _ -> Nothing) (f t) m
      AuditActionChange -> Map.insertLookupWithKey (const const) (f t) t m
      _ -> (activityPrev a, m)
  scan _ [] = []

maskPasswords :: [Activity] -> [Activity]
maskPasswords = mp HM.empty (0 :: Integer) where
  -- this could be done much more simply since passwords are never going to repeat in practice
  mp m c (a@Activity{ activityTarget = at@ActivityAccount{ activityAccountPassword = Just p } }:l)
    | Just i <- HM.lookup p m = f i : mp m c l
    | otherwise = f c : mp (HM.insert p c m) (succ c) l
    where f i = a{ activityTarget = at{ activityAccountPassword = Just $ BSC.pack $ show i } }
  mp m c (a:l) = a : mp m c l
  mp _ _ [] = []

lookupPartyActivity :: (MonadDB c m, MonadHasIdentity c m) => Party -> m [Activity]
lookupPartyActivity p = do
  ident <- peek
  pa <- chainPrev (const ())
    <$> dbQuery $(selectQuery selectActivityParty $ "WHERE party.id = ${partyId $ partyRow p} AND " ++ activityQual)
  ca <- chainPrev (const ()) . maskPasswords
    <$> dbQuery $(selectQuery selectActivityAccount "WHERE account.id = ${partyId $ partyRow p} ORDER BY audit_time") -- unqual: include logins
  aa <- chainPrev (partyId . partyRow . authorizeChild . authorization . activityAuthorize)
    <$> dbQuery $(selectQuery (selectActivityAuthorize 'p 'ident) $ "WHERE " ++ activityQual)
  return $ mergeActivities [pa, ca, aa]

lookupVolumeActivity :: (MonadDB c m, MonadHasIdentity c m) => Volume -> m [Activity]
lookupVolumeActivity vol = do
  ident <- peek
  va <- chainPrev (const ())
    <$> dbQuery $(selectQuery selectActivityVolume $ "!WHERE volume.id = ${volumeId $ volumeRow vol} AND " ++ activityQual)
  aa <- chainPrev (partyId . partyRow . volumeAccessParty . activityAccess)
    <$> dbQuery $(selectQuery (selectActivityAccess 'vol 'ident) $ "WHERE " ++ activityQual)
  return $ mergeActivities [va, aa]

addAssetRevision :: (MonadDB c m, MonadHasIdentity c m) => Volume -> Activity -> m Activity
addAssetRevision vol
  act@Activity{ activityAudit = Audit{ auditAction = aa }, activityTarget = ActivityAssetSlot{ activityAssetId = ai }, activityPrev = Nothing }
  | aa <= AuditActionChange = do
    ar <- if aa == AuditActionChange then lookupAssetReplace a else return Nothing
    at <- lookupAssetTranscode a
    return act
      { activityReplace = revisionOrig <$> ar
      , activityTranscode = revisionOrig <$> at
      }
    where
    a = ba{ assetRow = (assetRow ba){ assetId = ai } }
    ba = blankAsset vol
addAssetRevision _ a = return a

mergeAssetCreation :: [Activity] -> [Activity]
mergeAssetCreation = joinActivitiesWith f1 where
  f1 a@Activity{ activityAudit = Audit{ auditAction = AuditActionAdd  }, activityTarget = ActivityAsset aa, activityPrev = Nothing } = Just f2 where
    f2 Activity{ activityAudit = Audit{ auditAction = AuditActionChange }, activityTarget = ActivityAsset ac, activityPrev = Just (ActivityAsset aa') }
      | assetId aa == assetId aa' = Just a{ activityTarget = ActivityAsset ac, activityPrev = Just (ActivityAsset aa) }
    f2 _ = Nothing
  f1 _ = Nothing

mergeActivityAssetAndSlot :: ActivityTarget -> ActivityTarget -> Maybe ActivityTarget
mergeActivityAssetAndSlot (ActivityAsset ar) (ActivityAssetSlot ai si) =
  (assetId ar == ai) `thenUse` ActivityAssetAndSlot ar si
mergeActivityAssetAndSlot _ _ = Nothing

mergeAssetAndSlot :: [Activity] -> [Activity]
mergeAssetAndSlot = joinActivitiesWith f1 where
  f1 Activity{ activityAudit = a1, activityTarget = t1, activityPrev = p1, activityReplace = Nothing, activityTranscode = Nothing } = Just f2 where
    f2 a@Activity{ activityAudit = a2, activityTarget = t2, activityPrev = p2 }
      | auditAction a1 <= auditAction a2 && auditAction a2 <= AuditActionChange
      , Just t <- mergeActivityAssetAndSlot t1 t2 = Just a
        { activityAudit = a1
        , activityTarget = t
        , activityPrev = (do
          p1t <- p1
          mergeActivityAssetAndSlot p1t =<< p2) <|> p1 <|> p2
        }
    f2 _ = Nothing
  f1 _ = Nothing

lookupContainerActivity :: (MonadDB c m, MonadHasIdentity c m) => Container -> m [Activity]
lookupContainerActivity cont = do
  ca <- chainPrev (const ())
    <$> dbQuery $(selectQuery selectActivityContainer $ "WHERE container.id = ${containerId $ containerRow cont} AND " ++ activityQual)
  ra <- chainPrev (slotSegmentId . activitySlotId)
    <$> dbQuery $(selectQuery selectActivityRelease $ "WHERE slot_release.container = ${containerId $ containerRow cont} AND " ++ activityQual)

  asa <- mapM (addAssetRevision (containerVolume cont)) =<< chainPrev activityAssetId
    <$> dbQuery $(selectQuery selectActivityAssetSlot $ "WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)

  caa <- mergeAssetCreation . chainPrev (assetId . activityAssetRow)
    <$> dbQuery $(selectQuery selectActivityAsset $ "JOIN slot_asset ON asset.id = slot_asset.asset WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)
  let uam m Activity{ activityAudit = Audit{ auditAction = AuditActionRemove, auditWhen = t }, activityTarget = ActivityAssetSlot{ activityAssetId = a } } =
        Map.insert a t m
      uam m Activity{ activityAudit = Audit{ auditAction = AuditActionChange, auditWhen = t }, activityReplace = Just ar } =
        Map.insert (assetId $ assetRow ar) t m
      uam m _ = m
      dam = flip $ Map.delete . assetId . activityAssetRow . activityTarget
      oal = Map.toList $ foldl' dam (foldl' uam Map.empty asa) caa
  oaa <- forM oal $ \(ai, at) ->
    mergeAssetCreation . chainPrev (const ())
      <$> dbQuery $(selectQuery selectActivityAsset $ "WHERE asset.id = ${ai} AND audit_time <= ${at} AND " ++ activityQual)

  cea <- chainPrev (activityAssetId &&& activitySegment)
    <$> dbQuery $(selectQuery selectActivityExcerpt $ "JOIN slot_asset ON excerpt.asset = slot_asset.asset WHERE slot_asset.container = ${containerId $ containerRow cont} AND " ++ activityQual)

  return $ mergeAssetAndSlot $ mergeActivities (ca:ra:asa:cea:caa:oaa)

-- EDIT permission assumed for all
activityTargetJSON :: ActivityTarget -> (T.Text, JSON.Object, JSON.Object)
activityTargetJSON (ActivityParty p) =
  ("party", mempty, JSON.recordObject $
    partyRowJSON p)
activityTargetJSON ActivityAccount{..} =
  ("account", mempty,
    "email" JSON..= activityAccountEmail <> "password" JSON..= activityAccountPassword)
activityTargetJSON (ActivityAuthorize a) =
  ("authorize", "party" JSON..=: partyJSON (authorizeChild $ authorization a),
    authorizeJSON a)
activityTargetJSON (ActivityVolume v) =
  ("volume", mempty, JSON.recordObject $
    volumeRowJSON v `JSON.foldObjectIntoRec`
      ("alias" `JSON.kvObjectOrEmpty` volumeAlias v))
activityTargetJSON (ActivityAccess a) =
  ("access", "party" JSON..=: partyJSON (volumeAccessParty a),
    volumeAccessJSON a)
activityTargetJSON (ActivityContainer c) =
  ("container", mempty, JSON.recordObject $
    containerRowJSON False c `JSON.foldObjectIntoRec` -- False assumes edit level on volume for activity route
      ("date" `JSON.kvObjectOrEmpty` containerDate c))
activityTargetJSON ActivityRelease{..} =
  ("release", segmentJSON $ slotSegmentId activitySlotId,
    "release" JSON..= activityRelease)
activityTargetJSON (ActivityAsset a) =
  ("asset", "id" JSON..= assetId a,
    "classification" `JSON.kvObjectOrEmpty` assetRelease a <> "name" `JSON.kvObjectOrEmpty` assetName a)
activityTargetJSON (ActivityAssetSlot a s) =
  ("asset", "id" JSON..= a,
    segmentJSON $ slotSegmentId s)
activityTargetJSON (ActivityAssetAndSlot a s) = (n, i, o <> segmentJSON (slotSegmentId s)) where
  (n, i, o) = activityTargetJSON (ActivityAsset a)
activityTargetJSON ActivityExcerpt{..} =
  ("excerpt", "id" JSON..= activityAssetId <> segmentJSON activitySegment,
    "excerpt" `JSON.kvObjectOrEmpty` activityExcerptRelease)

activityAssetJSON :: Asset -> JSON.Object
activityAssetJSON a =
  JSON.recordObject $ assetJSON False a
      `JSON.foldObjectIntoRec` ("name" `JSON.kvObjectOrEmpty` assetName (assetRow a)) -- False assumes edit

activityJSON :: Activity -> Maybe JSON.Object
activityJSON Activity{ activityAudit = Audit{..}, ..} = (auditAction == AuditActionChange && HM.null new && HM.null old) `unlessUse`
  (new <> key
    <> "when" JSON..= auditWhen
    <> "action" JSON..= show auditAction
    <> "ip" JSON..= show (auditIp auditIdentity)
    <> "user" JSON..= auditWho auditIdentity
    <> "type" JSON..= typ
    <> "old" `JSON.kvObjectOrEmpty` (if HM.null old then empty else pure old)
    <> "replace" `JSON.kvObjectOrEmpty` (activityAssetJSON <$> activityReplace)
    <> "transcode" `JSON.kvObjectOrEmpty` (activityAssetJSON <$> activityTranscode))
  where
  (new, old)
    | auditAction == AuditActionRemove
      = (HM.empty, targ)
    | Just p <- activityPrev
    , (_, _, prev) <- activityTargetJSON p
    , int <- HM.filter id $ HM.intersectionWith (==) targ prev
      = (if auditAction == AuditActionAdd then targ else HM.difference targ int, HM.difference prev int)
    | otherwise
      = (targ, HM.empty)
  (typ, key, targ) = activityTargetJSON activityTarget