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