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 -}