1 {-# LANGUAGE OverloadedStrings, DataKinds #-} 2 module 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 Ops 26 import Has (view) 27 import Service.DB 28 import qualified JSON 29 import Model.SQL 30 import Model.Permission 31 import Model.Audit 32 import Model.Metric 33 import Model.Record.Types 34 import Model.Release.Types 35 -- import Model.Measure.SQL 36 import Model.PermissionUtil (maskRestrictedString) 37 -- import qualified Model.Measure.SQL 38 import 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 (setMeasureDatum 81 m) 82 (mapQuery 83 ((\ _p_a6DoT _p_a6DoU _p_a6DoV _p_a6DoW _p_a6DoX -> 84 (Data.ByteString.concat 85 [Data.String.fromString 86 "WITH audit_row AS (UPDATE measure SET datum=", 87 Database.PostgreSQL.Typed.Types.pgEscapeParameter 88 _tenv_a6DoS 89 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 90 _p_a6DoT, 91 Data.String.fromString " WHERE record=", 92 Database.PostgreSQL.Typed.Types.pgEscapeParameter 93 _tenv_a6DoS 94 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 95 PGTypeName "integer") 96 _p_a6DoU, 97 Data.String.fromString " AND metric=", 98 Database.PostgreSQL.Typed.Types.pgEscapeParameter 99 _tenv_a6DoS 100 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 101 PGTypeName "integer") 102 _p_a6DoV, 103 Data.String.fromString 104 " RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 105 Database.PostgreSQL.Typed.Types.pgEscapeParameter 106 _tenv_a6DoS 107 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 108 PGTypeName "integer") 109 _p_a6DoW, 110 Data.String.fromString ", ", 111 Database.PostgreSQL.Typed.Types.pgEscapeParameter 112 _tenv_a6DoS 113 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 114 _p_a6DoX, 115 Data.String.fromString 116 ", 'change'::audit.action, * FROM audit_row RETURNING measure.datum"])) 117 (measureDatum m) 118 (recordId $ recordRow $ measureRecord m) 119 (metricId $ measureMetric m) 120 (auditWho ident) 121 (auditIp ident)) 122 (\[_cdatum_a6DoY] 123 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 124 _tenv_a6DoS 125 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 126 _cdatum_a6DoY)))) 127 -- .(insertMeasure 'ident 'm) 128 (fmap 129 (setMeasureDatum 130 m) 131 (mapQuery 132 ((\ _p_a6DpC _p_a6DpD _p_a6DpE _p_a6DpF _p_a6DpG -> 133 (Data.ByteString.concat 134 [Data.String.fromString 135 "WITH audit_row AS (INSERT INTO measure (record,metric,datum) VALUES (", 136 Database.PostgreSQL.Typed.Types.pgEscapeParameter 137 _tenv_a6DpB 138 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 139 PGTypeName "integer") 140 _p_a6DpC, 141 Data.String.fromString ",", 142 Database.PostgreSQL.Typed.Types.pgEscapeParameter 143 _tenv_a6DpB 144 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 145 PGTypeName "integer") 146 _p_a6DpD, 147 Data.String.fromString ",", 148 Database.PostgreSQL.Typed.Types.pgEscapeParameter 149 _tenv_a6DpB 150 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 151 _p_a6DpE, 152 Data.String.fromString 153 ") RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 154 Database.PostgreSQL.Typed.Types.pgEscapeParameter 155 _tenv_a6DpB 156 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 157 PGTypeName "integer") 158 _p_a6DpF, 159 Data.String.fromString ", ", 160 Database.PostgreSQL.Typed.Types.pgEscapeParameter 161 _tenv_a6DpB 162 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 163 _p_a6DpG, 164 Data.String.fromString 165 ", 'add'::audit.action, * FROM audit_row RETURNING measure.datum"])) 166 (recordId $ recordRow $ measureRecord m) 167 (metricId $ measureMetric m) 168 (measureDatum m) 169 (auditWho ident) 170 (auditIp ident)) 171 (\ [_cdatum_a6DpH] 172 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 173 _tenv_a6DpB 174 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "text") 175 _cdatum_a6DpH)))) 176 case r of 177 Left () -> return Nothing 178 Right (_, [d]) -> return $ Just $ upMeasure d 179 Right (n, _) -> fail $ "changeRecordMeasure: " ++ show n ++ " rows" 180 181 removeRecordMeasure :: MonadAudit c m => Measure -> m Record 182 removeRecordMeasure m = do 183 ident <- getAuditIdentity 184 let _tenv_a6Dqm = unknownPGTypeEnv 185 r <- dbExecute1 -- .(deleteMeasure 'ident 'm) 186 (mapQuery 187 ((\ _p_a6Dqn _p_a6Dqo _p_a6Dqp _p_a6Dqq -> 188 (Data.ByteString.concat 189 [Data.String.fromString 190 "WITH audit_row AS (DELETE FROM measure WHERE record=", 191 Database.PostgreSQL.Typed.Types.pgEscapeParameter 192 _tenv_a6Dqm 193 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 194 PGTypeName "integer") 195 _p_a6Dqn, 196 Data.String.fromString " AND metric=", 197 Database.PostgreSQL.Typed.Types.pgEscapeParameter 198 _tenv_a6Dqm 199 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 200 PGTypeName "integer") 201 _p_a6Dqo, 202 Data.String.fromString 203 " RETURNING *) INSERT INTO audit.measure SELECT CURRENT_TIMESTAMP, ", 204 Database.PostgreSQL.Typed.Types.pgEscapeParameter 205 _tenv_a6Dqm 206 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 207 PGTypeName "integer") 208 _p_a6Dqp, 209 Data.String.fromString ", ", 210 Database.PostgreSQL.Typed.Types.pgEscapeParameter 211 _tenv_a6Dqm 212 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: PGTypeName "inet") 213 _p_a6Dqq, 214 Data.String.fromString 215 ", 'remove'::audit.action, * FROM audit_row"])) 216 (recordId $ recordRow $ measureRecord m) 217 (metricId $ measureMetric m) 218 (auditWho ident) 219 (auditIp ident)) 220 (\[] -> ())) 221 return $ if r 222 then rmMeasure m 223 else measureRecord m 224 225 -- | Enforce release on record somehow??? 226 getRecordMeasures :: Record -> Measures 227 getRecordMeasures r = 228 case readRelease ((extractPermissionIgnorePolicy . volumeRolePolicy . recordVolume) r) of -- reads better with case than maybe 229 Nothing -> 230 [] 231 Just rel -> 232 filter (viewerCanView rel) (recordMeasures r) 233 where 234 rcrdRel :: Release 235 rcrdRel = 236 (fold . recordRelease) r -- use monoid, defaulting to PRIVATE 237 requiredRelease :: Measure -> Release 238 requiredRelease m = 239 let 240 mMsrRel = view m 241 in 242 fromMaybe rcrdRel mMsrRel 243 viewerCanView :: Release -> Measure -> Bool 244 viewerCanView viewerDeepestAllowedRelease m = 245 viewerDeepestAllowedRelease <= requiredRelease m 246 247 decodeMeasure :: PGColumn t d => PGTypeName t -> Measure -> Maybe d 248 decodeMeasure t Measure{ measureMetric = Metric{ metricType = m }, measureDatum = d } = 249 (pgTypeName t == show m) `thenUse` pgDecode t d 250 251 measureJSONPair :: JSON.KeyValue kv => Bool -> Measure -> kv 252 measureJSONPair publicRestricted m = 253 T.pack (show (metricId (measureMetric m))) 254 JSON..= (if publicRestricted then maskRestrictedString . measureDatum else measureDatum) m 255 256 measuresJSON :: JSON.ToObject o => Bool -> Measures -> o 257 measuresJSON publicRestricted = foldMap (measureJSONPair publicRestricted) 258 259 {- 260 measuresJSONRestricted :: JSON.ToObject o => Measures -> o 261 measuresJSONRestricted = foldMap measureJSONPairRestricted 262 -}