1 {-# LANGUAGE OverloadedStrings, RecordWildCards, DataKinds #-}
    2 module Model.Slot
    3   ( module Model.Slot.Types
    4   , lookupSlot
    5   , lookupContainerSlot
    6   , auditSlotDownload
    7   , slotJSON
    8   ) where
    9 
   10 import Database.PostgreSQL.Typed.Types
   11 import qualified Data.String
   12 
   13 import qualified JSON
   14 import Service.DB
   15 import Model.Id
   16 import Model.Identity
   17 import Model.Audit
   18 import Model.Segment
   19 import Model.Container
   20 import Model.Slot.Types
   21 
   22 -- | Look up a Slot by its Id, gated by the running Identity's permission to view
   23 -- the Slot's Container's Volume. :)
   24 lookupSlot :: (MonadDB c m, MonadHasIdentity c m) => Id Slot -> m (Maybe Slot)
   25 lookupSlot (Id (SlotId cont seg)) =
   26   fmap (`Slot` seg) <$> lookupContainer cont
   27 
   28 -- | Look up a Slot by its Container's Id, gated by the running Identity's
   29 -- permission to view the Volume containing the Container (which contains the
   30 -- Slot).
   31 lookupContainerSlot :: (MonadDB c m, MonadHasIdentity c m) => Id Container -> m (Maybe Slot)
   32 lookupContainerSlot = lookupSlot . containerSlotId
   33 
   34 auditSlotDownload :: MonadAudit c m => Bool -> Slot -> m ()
   35 auditSlotDownload success Slot{ slotContainer = c, slotSegment = seg } = do
   36   let _tenv_abUAX = unknownPGTypeEnv
   37   ai <- getAuditIdentity
   38   dbExecute1' -- [pgSQL|$INSERT INTO audit.slot (audit_action, audit_user, audit_ip, container, segment) VALUES
   39     -- (${if success then AuditActionOpen else AuditActionAttempt}, ${auditWho ai}, ${auditIp ai}, ${containerId $ containerRow c}, ${seg})|]
   40    (mapPrepQuery
   41     ((\ _p_abUAY _p_abUAZ _p_abUB0 _p_abUB1 _p_abUB2 ->
   42                     (Data.String.fromString
   43                        "INSERT INTO audit.slot (audit_action, audit_user, audit_ip, container, segment) VALUES\n\
   44                        \    ($1, $2, $3, $4, $5)",
   45                     [Database.PostgreSQL.Typed.Types.pgEncodeParameter
   46                        _tenv_abUAX
   47                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   48                           Database.PostgreSQL.Typed.Types.PGTypeName "audit.action")
   49                        _p_abUAY,
   50                      Database.PostgreSQL.Typed.Types.pgEncodeParameter
   51                        _tenv_abUAX
   52                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   53                           Database.PostgreSQL.Typed.Types.PGTypeName "integer")
   54                        _p_abUAZ,
   55                      Database.PostgreSQL.Typed.Types.pgEncodeParameter
   56                        _tenv_abUAX
   57                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   58                           Database.PostgreSQL.Typed.Types.PGTypeName "inet")
   59                        _p_abUB0,
   60                      Database.PostgreSQL.Typed.Types.pgEncodeParameter
   61                        _tenv_abUAX
   62                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   63                           Database.PostgreSQL.Typed.Types.PGTypeName "integer")
   64                        _p_abUB1,
   65                      Database.PostgreSQL.Typed.Types.pgEncodeParameter
   66                        _tenv_abUAX
   67                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   68                           Database.PostgreSQL.Typed.Types.PGTypeName "segment")
   69                        _p_abUB2]))
   70       (if success then AuditActionOpen else AuditActionAttempt)
   71       (auditWho ai)
   72       (auditIp ai)
   73       (containerId $ containerRow c)
   74       seg)
   75     (\ [] -> ()))
   76 
   77 slotJSON :: JSON.ToObject o => Slot -> JSON.Record (Id Container) o
   78 slotJSON Slot{..} = containerJSON False slotContainer -- probably add bool to slotJSON
   79   `JSON.foldObjectIntoRec` segmentJSON slotSegment