1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, DataKinds #-} 2 module Model.Container 3 ( module Model.Container.Types 4 , blankContainer 5 , lookupContainer 6 , lookupVolumeContainer 7 , lookupVolumeContainers 8 , lookupVolumeTopContainer 9 , containerIsVolumeTop 10 , addContainer 11 , changeContainer 12 , removeContainer 13 , getContainerDate 14 , formatContainerDate 15 , containerRowJSON 16 , containerJSON 17 ) where 18 19 import Control.Monad (guard) 20 import qualified Data.ByteString 21 import Data.Either (isRight) 22 import Data.Monoid ((<>)) 23 import qualified Data.String 24 import Data.Time.Format (formatTime, defaultTimeLocale) 25 import Database.PostgreSQL.Typed.Types 26 -- import Database.PostgreSQL.Typed.Query (pgSQL) 27 28 import Ops 29 import Has (view, peek) 30 import Service.DB 31 import qualified JSON 32 import Model.SQL (selectQuery, isForeignKeyViolation) 33 import Model.Time 34 import Model.Permission 35 import Model.Id.Types 36 import Model.Party.Types 37 import Model.Identity 38 import Model.Audit 39 import Model.Volume.Types 40 import Model.Container.Types 41 import Model.Container.SQL 42 import Model.PermissionUtil (maskRestrictedString) 43 44 blankContainer :: Volume -> Container 45 blankContainer vol = Container 46 { containerRow = ContainerRow 47 { containerId = error "blankContainer" 48 , containerTop = False 49 , containerName = Nothing 50 , containerDate = Nothing 51 } 52 , containerRelease = Nothing 53 , containerVolume = vol 54 } 55 56 -- | Look up a Container by its Id, gated by the running Identity's permission 57 -- to view the Volume containing the Container. 58 lookupContainer :: (MonadDB c m, MonadHasIdentity c m) => Id Container -> m (Maybe Container) 59 lookupContainer ci = do 60 ident <- peek 61 dbQuery1 $(selectQuery (selectContainer 'ident) "$WHERE container.id = ${ci}") 62 63 lookupVolumeContainer :: MonadDB c m => Volume -> Id Container -> m (Maybe Container) 64 lookupVolumeContainer vol ci = 65 dbQuery1 $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.id = ${ci} AND container.volume = ${volumeId $ volumeRow vol}") 66 67 lookupVolumeContainers :: MonadDB c m => Volume -> m [Container] 68 lookupVolumeContainers vol = 69 dbQuery $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.volume = ${volumeId $ volumeRow vol} ORDER BY container.id") 70 71 lookupVolumeTopContainer :: MonadDB c m => Volume -> m Container 72 lookupVolumeTopContainer vol = 73 dbQuery1' $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.volume = ${volumeId $ volumeRow vol} ORDER BY container.id LIMIT 1") 74 75 containerIsVolumeTop :: MonadDB c m => Container -> m Bool 76 containerIsVolumeTop Container{ containerRow = ContainerRow{ containerTop = False } } = return False 77 containerIsVolumeTop c = do 78 let _tenv_a87pL = unknownPGTypeEnv 79 not <$> 80 dbExecute1 -- [pgSQL|SELECT FROM container WHERE volume = ${volumeId $ volumeRow $ containerVolume c} AND id < ${containerId $ containerRow c} LIMIT 1|] 81 (mapQuery2 82 ((\ _p_a87pM _p_a87pN -> 83 (Data.ByteString.concat 84 [Data.String.fromString "SELECT FROM container WHERE volume = ", 85 Database.PostgreSQL.Typed.Types.pgEscapeParameter 86 _tenv_a87pL 87 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 88 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 89 _p_a87pM, 90 Data.String.fromString " AND id < ", 91 Database.PostgreSQL.Typed.Types.pgEscapeParameter 92 _tenv_a87pL 93 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 94 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 95 _p_a87pN, 96 Data.String.fromString " LIMIT 1"])) 97 (volumeId $ volumeRow $ containerVolume c) 98 (containerId $ containerRow c)) 99 (\[] -> ())) 100 101 addContainer :: MonadAudit c m => Container -> m Container 102 addContainer bc = do 103 ident <- getAuditIdentity 104 let _tenv_a87ru = unknownPGTypeEnv 105 row <- dbQuery1' -- .(insertContainer 'ident 'bc) 106 (mapQuery2 107 ((\ _p_a87rv _p_a87rw _p_a87rx _p_a87ry _p_a87rz _p_a87rA -> 108 (Data.ByteString.concat 109 [Data.String.fromString 110 "WITH audit_row AS (INSERT INTO container (volume,top,name,date) VALUES (", 111 Database.PostgreSQL.Typed.Types.pgEscapeParameter 112 _tenv_a87ru 113 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 114 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 115 _p_a87rv, 116 Data.String.fromString ",", 117 Database.PostgreSQL.Typed.Types.pgEscapeParameter 118 _tenv_a87ru 119 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 120 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 121 _p_a87rw, 122 Data.String.fromString ",", 123 Database.PostgreSQL.Typed.Types.pgEscapeParameter 124 _tenv_a87ru 125 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 126 Database.PostgreSQL.Typed.Types.PGTypeName "text") 127 _p_a87rx, 128 Data.String.fromString ",", 129 Database.PostgreSQL.Typed.Types.pgEscapeParameter 130 _tenv_a87ru 131 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 132 Database.PostgreSQL.Typed.Types.PGTypeName "date") 133 _p_a87ry, 134 Data.String.fromString 135 ") RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ", 136 Database.PostgreSQL.Typed.Types.pgEscapeParameter 137 _tenv_a87ru 138 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 139 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 140 _p_a87rz, 141 Data.String.fromString ", ", 142 Database.PostgreSQL.Typed.Types.pgEscapeParameter 143 _tenv_a87ru 144 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 145 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 146 _p_a87rA, 147 Data.String.fromString 148 ", 'add'::audit.action, * FROM audit_row RETURNING container.id"])) 149 (volumeId $ volumeRow $ containerVolume bc) 150 (containerTop $ containerRow bc) 151 (containerName $ containerRow bc) 152 (containerDate $ containerRow bc) 153 (auditWho ident) 154 (auditIp ident)) 155 (\[_cid_a87rB] 156 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 157 _tenv_a87ru 158 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 159 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 160 _cid_a87rB))) 161 pure 162 (Model.Container.SQL.setContainerId bc 163 row) 164 165 166 changeContainer :: MonadAudit c m => Container -> m () 167 changeContainer c = do 168 ident <- getAuditIdentity 169 let _tenv_a87BH = unknownPGTypeEnv 170 dbExecute1' -- .(updateContainer 'ident 'c) 171 (mapQuery2 172 ((\ _p_a87BI _p_a87BJ _p_a87BK _p_a87BL _p_a87BM _p_a87BN _p_a87BO -> 173 (Data.ByteString.concat 174 [Data.String.fromString 175 "WITH audit_row AS (UPDATE container SET volume=", 176 Database.PostgreSQL.Typed.Types.pgEscapeParameter 177 _tenv_a87BH 178 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 179 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 180 _p_a87BI, 181 Data.String.fromString ",top=", 182 Database.PostgreSQL.Typed.Types.pgEscapeParameter 183 _tenv_a87BH 184 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 185 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 186 _p_a87BJ, 187 Data.String.fromString ",name=", 188 Database.PostgreSQL.Typed.Types.pgEscapeParameter 189 _tenv_a87BH 190 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 191 Database.PostgreSQL.Typed.Types.PGTypeName "text") 192 _p_a87BK, 193 Data.String.fromString ",date=", 194 Database.PostgreSQL.Typed.Types.pgEscapeParameter 195 _tenv_a87BH 196 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 197 Database.PostgreSQL.Typed.Types.PGTypeName "date") 198 _p_a87BL, 199 Data.String.fromString " WHERE id=", 200 Database.PostgreSQL.Typed.Types.pgEscapeParameter 201 _tenv_a87BH 202 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 203 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 204 _p_a87BM, 205 Data.String.fromString 206 " RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ", 207 Database.PostgreSQL.Typed.Types.pgEscapeParameter 208 _tenv_a87BH 209 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 210 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 211 _p_a87BN, 212 Data.String.fromString ", ", 213 Database.PostgreSQL.Typed.Types.pgEscapeParameter 214 _tenv_a87BH 215 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 216 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 217 _p_a87BO, 218 Data.String.fromString 219 ", 'change'::audit.action, * FROM audit_row"])) 220 (volumeId $ volumeRow $ containerVolume c) 221 (containerTop $ containerRow c) 222 (containerName $ containerRow c) 223 (containerDate $ containerRow c) 224 (containerId $ containerRow c) 225 (auditWho ident) 226 (auditIp ident)) 227 (\[] -> ())) 228 229 removeContainer :: MonadAudit c m => Container -> m Bool 230 removeContainer c = do 231 ident <- getAuditIdentity 232 let (_tenv_a87HO, _tenv_a87LM) = (unknownPGTypeEnv, unknownPGTypeEnv) 233 top <- dbQuery1' -- [pgSQL|SELECT id FROM container WHERE volume = ${volumeId $ volumeRow $ containerVolume c} ORDER BY id LIMIT 1|] 234 (mapQuery2 235 ((\ _p_a87HP -> 236 Data.ByteString.concat 237 [Data.String.fromString "SELECT id FROM container WHERE volume = ", 238 Database.PostgreSQL.Typed.Types.pgEscapeParameter 239 _tenv_a87HO 240 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 241 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 242 _p_a87HP, 243 Data.String.fromString " ORDER BY id LIMIT 1"]) 244 (volumeId $ volumeRow $ containerVolume c)) 245 (\[_cid_a87HR] 246 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 247 _tenv_a87HO 248 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 249 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 250 _cid_a87HR))) 251 if top == containerId (containerRow c) 252 then return False 253 else 254 isRight 255 <$> 256 dbTryJust 257 (guard . isForeignKeyViolation) 258 (dbExecute1 -- .(deleteContainer 'ident 'c)) 259 (mapQuery2 260 ((\ _p_a87LN _p_a87LO _p_a87LP -> 261 (Data.ByteString.concat 262 [Data.String.fromString 263 "WITH audit_row AS (DELETE FROM container WHERE id=", 264 Database.PostgreSQL.Typed.Types.pgEscapeParameter 265 _tenv_a87LM 266 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 267 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 268 _p_a87LN, 269 Data.String.fromString 270 " RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ", 271 Database.PostgreSQL.Typed.Types.pgEscapeParameter 272 _tenv_a87LM 273 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 274 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 275 _p_a87LO, 276 Data.String.fromString ", ", 277 Database.PostgreSQL.Typed.Types.pgEscapeParameter 278 _tenv_a87LM 279 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 280 Database.PostgreSQL.Typed.Types.PGTypeName "inet") 281 _p_a87LP, 282 Data.String.fromString 283 ", 'remove'::audit.action, * FROM audit_row"])) 284 (containerId $ containerRow c) (auditWho ident) (auditIp ident)) 285 (\ [] -> ()))) 286 287 getContainerDate :: Container -> Maybe MaskedDate 288 getContainerDate c = 289 maskDateIf (not (canReadData2 getContainerRelease getContainerVolumeRole c)) 290 <$> containerDate (containerRow c) 291 292 formatContainerDate :: Container -> Maybe String 293 formatContainerDate c = formatTime defaultTimeLocale "%Y-%m-%d" <$> getContainerDate c 294 295 containerRowJSON :: JSON.ToObject o => Bool -> ContainerRow -> JSON.Record (Id Container) o 296 containerRowJSON publicRestricted ContainerRow{..} = JSON.Record containerId $ 297 "top" `JSON.kvObjectOrEmpty` (True `useWhen` containerTop) 298 <> "name" `JSON.kvObjectOrEmpty` if publicRestricted then fmap maskRestrictedString containerName else containerName 299 300 containerJSON :: JSON.ToObject o => Bool -> Container -> JSON.Record (Id Container) o 301 containerJSON publicRestricted c@Container{..} = containerRowJSON publicRestricted containerRow `JSON.foldObjectIntoRec` 302 ( "date" `JSON.kvObjectOrEmpty` formatContainerDate c 303 <> "release" `JSON.kvObjectOrEmpty` containerRelease)