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