1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, DataKinds #-} 2 module Databrary.Model.Measure 3 ( getRecordMeasures 4 , getMeasure 5 , changeRecordMeasure 6 , removeRecordMeasure 7 , decodeMeasure 8 , measuresJSON 9 ) where 10 11 import Control.Monad (guard) 12 import Data.Foldable (fold) 13 import Data.List (find) 14 import Data.Maybe (fromMaybe) 15 import Data.Ord (comparing) 16 import qualified Data.Text as T 17 import Database.PostgreSQL.Typed.Protocol (PGError(..), pgErrorCode) 18 import Database.PostgreSQL.Typed.Types (PGTypeName, pgTypeName, PGColumn(pgDecode)) 19 import Database.PostgreSQL.Typed.Query 20 import Database.PostgreSQL.Typed.Types 21 import qualified Data.ByteString 22 import Data.ByteString (ByteString) 23 import qualified Data.String 24 25 import Databrary.Ops 26 import Databrary.Has (view) 27 import Databrary.Service.DB 28 import qualified Databrary.JSON as JSON 29 import Databrary.Model.SQL 30 import Databrary.Model.Permission 31 import Databrary.Model.Audit 32 import Databrary.Model.Metric 33 import Databrary.Model.Record.Types 34 import Databrary.Model.Release.Types 35 -- import Databrary.Model.Measure.SQL 36 import Databrary.Model.PermissionUtil (maskRestrictedString) 37 -- import qualified Databrary.Model.Measure.SQL 38 import Databrary.Model.Volume.Types 39 40 setMeasureDatum :: Measure -> MeasureDatum -> Measure 41 setMeasureDatum m d = m{ measureDatum = d } 42 43 measureOrder :: Measure -> Measure -> Ordering 44 measureOrder = comparing $ metricId . measureMetric 45 46 getMeasure :: Metric -> Measures -> Maybe Measure 47 getMeasure m = find ((metricId m ==) . metricId . measureMetric) 48 49 rmMeasure :: Measure -> Record 50 rmMeasure m@Measure{ measureRecord = rec } = rec{ recordMeasures = upd $ recordMeasures rec } where 51 upd [] = [m] 52 upd l@(m':l') = case m `measureOrder` m' of 53 GT -> m':upd l' 54 EQ -> l' 55 LT -> l 56 57 upMeasure :: Measure -> Record 58 upMeasure m@Measure{ measureRecord = rec } = rec{ recordMeasures = upd $ recordMeasures rec } where 59 upd [] = [m] 60 upd l@(m':l') = case m `measureOrder` m' of 61 GT -> m':upd l' 62 EQ -> m:l' 63 LT -> m:l 64 65 isInvalidInputException :: PGError -> Bool 66 isInvalidInputException e = pgErrorCode e `elem` ["22007", "22008", "22P02"] 67 68 mapQuery :: ByteString -> ([PGValue] -> a) -> PGSimpleQuery a 69 mapQuery qry mkResult = 70 fmap mkResult (rawPGSimpleQuery qry) 71 72 changeRecordMeasure :: MonadAudit c m => Measure -> m (Maybe Record) 73 changeRecordMeasure m = do 74 ident <- getAuditIdentity 75 let _tenv_a6DoS = unknownPGTypeEnv 76 _tenv_a6DpB = unknownPGTypeEnv 77 r <- tryUpdateOrInsert (guard . isInvalidInputException) 78 -- .(updateMeasure 'ident 'm) 79 (fmap 80 (\ (vdatum_a6DoR) 81 -> setMeasureDatum 82 m vdatum_a6DoR) 83 (mapQuery 84 ((\ _p_a6DoT _p_a6DoU _p_a6DoV _p_a6DoW _p_a6DoX -> 85 (Data.ByteString.concat 86 [Data.String.fromString 87 "WITH audit_row AS (UPDATE measure SET datum=", 88 Database.PostgreSQL.Typed.Types.pgEscapeParameter 89 _tenv_a6DoS 90 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 91 _p_a6DoT, 92 Data.String.fromString " WHERE record=", 93 Database.PostgreSQL.Typed.Types.pgEscapeParameter 94 _tenv_a6DoS 95 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 96 PGTypeName "integer") 97 _p_a6DoU, 98 Data.String.fromString " AND metric=", 99 Database.PostgreSQL.Typed.Types.pgEscapeParameter 100 _tenv_a6DoS 101 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 102 PGTypeName "integer") 103 _p_a6DoV, 104 Data.String.fromString 105 " RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 106 Database.PostgreSQL.Typed.Types.pgEscapeParameter 107 _tenv_a6DoS 108 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 109 PGTypeName "integer") 110 _p_a6DoW, 111 Data.String.fromString ", ", 112 Database.PostgreSQL.Typed.Types.pgEscapeParameter 113 _tenv_a6DoS 114 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 115 _p_a6DoX, 116 Data.String.fromString 117 ", 'change'::audit.action, * FROM audit_row RETURNING measure.datum"])) 118 (measureDatum m) 119 (recordId $ recordRow $ measureRecord m) 120 (metricId $ measureMetric m) 121 (auditWho ident) 122 (auditIp ident)) 123 (\[_cdatum_a6DoY] 124 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 125 _tenv_a6DoS 126 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 127 _cdatum_a6DoY)))) 128 -- .(insertMeasure 'ident 'm) 129 (fmap 130 (\ (vdatum_a6Dpm) 131 -> setMeasureDatum 132 m vdatum_a6Dpm) 133 (mapQuery 134 ((\ _p_a6DpC _p_a6DpD _p_a6DpE _p_a6DpF _p_a6DpG -> 135 (Data.ByteString.concat 136 [Data.String.fromString 137 "WITH audit_row AS (INSERT INTO measure (record,metric,datum) VALUES (", 138 Database.PostgreSQL.Typed.Types.pgEscapeParameter 139 _tenv_a6DpB 140 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 141 PGTypeName "integer") 142 _p_a6DpC, 143 Data.String.fromString ",", 144 Database.PostgreSQL.Typed.Types.pgEscapeParameter 145 _tenv_a6DpB 146 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 147 PGTypeName "integer") 148 _p_a6DpD, 149 Data.String.fromString ",", 150 Database.PostgreSQL.Typed.Types.pgEscapeParameter 151 _tenv_a6DpB 152 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 153 _p_a6DpE, 154 Data.String.fromString 155 ") RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 156 Database.PostgreSQL.Typed.Types.pgEscapeParameter 157 _tenv_a6DpB 158 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 159 PGTypeName "integer") 160 _p_a6DpF, 161 Data.String.fromString ", ", 162 Database.PostgreSQL.Typed.Types.pgEscapeParameter 163 _tenv_a6DpB 164 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 165 _p_a6DpG, 166 Data.String.fromString 167 ", 'add'::audit.action, * FROM audit_row RETURNING measure.datum"])) 168 (recordId $ recordRow $ measureRecord m) 169 (metricId $ measureMetric m) 170 (measureDatum m) 171 (auditWho ident) 172 (auditIp ident)) 173 (\ [_cdatum_a6DpH] 174 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 175 _tenv_a6DpB 176 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 177 _cdatum_a6DpH)))) 178 case r of 179 Left () -> return Nothing 180 Right (_, [d]) -> return $ Just $ upMeasure d 181 Right (n, _) -> fail $ "changeRecordMeasure: " ++ show n ++ " rows" 182 183 removeRecordMeasure :: MonadAudit c m => Measure -> m Record 184 removeRecordMeasure m = do 185 ident <- getAuditIdentity 186 let _tenv_a6Dqm = unknownPGTypeEnv 187 r <- dbExecute1 -- .(deleteMeasure 'ident 'm) 188 (mapQuery 189 ((\ _p_a6Dqn _p_a6Dqo _p_a6Dqp _p_a6Dqq -> 190 (Data.ByteString.concat 191 [Data.String.fromString 192 "WITH audit_row AS (DELETE FROM measure WHERE record=", 193 Database.PostgreSQL.Typed.Types.pgEscapeParameter 194 _tenv_a6Dqm 195 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 196 PGTypeName "integer") 197 _p_a6Dqn, 198 Data.String.fromString " AND metric=", 199 Database.PostgreSQL.Typed.Types.pgEscapeParameter 200 _tenv_a6Dqm 201 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 202 PGTypeName "integer") 203 _p_a6Dqo, 204 Data.String.fromString 205 " RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 206 Database.PostgreSQL.Typed.Types.pgEscapeParameter 207 _tenv_a6Dqm 208 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 209 PGTypeName "integer") 210 _p_a6Dqp, 211 Data.String.fromString ", ", 212 Database.PostgreSQL.Typed.Types.pgEscapeParameter 213 _tenv_a6Dqm 214 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 215 _p_a6Dqq, 216 Data.String.fromString 217 ", 'remove'::audit.action, * FROM audit_row"])) 218 (recordId $ recordRow $ measureRecord m) 219 (metricId $ measureMetric m) 220 (auditWho ident) 221 (auditIp ident)) 222 (\[] -> ())) 223 return $ if r 224 then rmMeasure m 225 else measureRecord m 226 227 -- | Enforce release on record somehow??? 228 getRecordMeasures :: Record -> Measures 229 getRecordMeasures r = 230 case readRelease ((extractPermissionIgnorePolicy . volumeRolePolicy . recordVolume) r) of -- reads better with case than maybe 231 Nothing -> 232 [] 233 Just rel -> 234 filter (viewerCanView rel) (recordMeasures r) 235 where 236 rcrdRel :: Release 237 rcrdRel = 238 (fold . recordRelease) r -- use monoid, defaulting to PRIVATE 239 requiredRelease :: Measure -> Release 240 requiredRelease m = 241 let 242 mMsrRel = view m 243 in 244 fromMaybe rcrdRel mMsrRel 245 viewerCanView :: Release -> Measure -> Bool 246 viewerCanView viewerDeepestAllowedRelease m = 247 viewerDeepestAllowedRelease <= requiredRelease m 248 249 decodeMeasure :: PGColumn t d => PGTypeName t -> Measure -> Maybe d 250 decodeMeasure t Measure{ measureMetric = Metric{ metricType = m }, measureDatum = d } = 251 (pgTypeName t == show m) `thenUse` (pgDecode t d) 252 253 measureJSONPair :: JSON.KeyValue kv => Bool -> Measure -> kv 254 measureJSONPair publicRestricted m = 255 T.pack (show (metricId (measureMetric m))) 256 JSON..= (if publicRestricted then maskRestrictedString . measureDatum else measureDatum) m 257 258 measuresJSON :: JSON.ToObject o => Bool -> Measures -> o 259 measuresJSON publicRestricted = foldMap (measureJSONPair publicRestricted) 260 261 {- 262 measuresJSONRestricted :: JSON.ToObject o => Measures -> o 263 measuresJSONRestricted = foldMap measureJSONPairRestricted 264 -}