1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, RecordWildCards, DataKinds #-}
    2 module Databrary.Model.Record
    3   ( module Databrary.Model.Record.Types
    4   , lookupRecord
    5   , lookupVolumeRecord
    6   , lookupVolumeParticipant
    7   , lookupVolumeRecords
    8   , addRecord
    9   , changeRecord
   10   , removeRecord
   11   , recordJSON
   12   , columnSampleJson
   13 --  , recordJSONRestricted
   14   -- for testing only
   15   , extractParticipantFieldRows
   16   ) where
   17 
   18 import Control.Monad (guard)
   19 import qualified Data.ByteString as BS
   20 import qualified Data.Csv as CSV
   21 import Data.Either (isRight)
   22 import Data.List (find)
   23 import Data.Monoid ((<>))
   24 import Data.Vector (Vector)
   25 
   26 import Data.Csv.Contrib (extractColumnDefaulting)
   27 import Databrary.Has (peek, view)
   28 import Databrary.Service.DB
   29 import qualified Databrary.JSON as JSON
   30 import Databrary.Model.SQL
   31 import Databrary.Model.Audit
   32 import Databrary.Model.Id
   33 import Databrary.Model.Identity.Types
   34 import Databrary.Model.Volume.Types
   35 import Databrary.Model.Party.Types
   36 import Databrary.Model.Category
   37 import Databrary.Model.Measure
   38 import Databrary.Model.Metric
   39 import Databrary.Model.Record.Types
   40 import Databrary.Model.Record.SQL
   41 
   42 lookupRecord :: (MonadHasIdentity c m, MonadDB c m) => Id Record -> m (Maybe Record)
   43 lookupRecord ri = do
   44   ident <- peek
   45   dbQuery1 $(selectQuery (selectRecord 'ident) "$WHERE record.id = ${ri}")
   46 
   47 lookupVolumeRecord :: MonadDB c m => Volume -> Id Record -> m (Maybe Record)
   48 lookupVolumeRecord vol ri =
   49   dbQuery1 $ fmap ($ vol) $(selectQuery selectVolumeRecord "$WHERE record.id = ${ri} AND record.volume = ${volumeId $ volumeRow vol}")
   50 
   51 lookupVolumeParticipant :: MonadDB c m => Volume -> MeasureDatum -> m (Maybe Record)
   52 lookupVolumeParticipant vol idMeasureVal = do
   53     allVolumeRecords <- lookupVolumeRecords vol
   54     let mIdMatch = find matchesId allVolumeRecords
   55     -- check record type is participant, if not, then error
   56     pure mIdMatch
   57   where
   58     idMetric :: Metric
   59     idMetric = getMetric' (Id 1)
   60     matchesId :: Record -> Bool
   61     matchesId r =
   62          maybe
   63            False
   64            (const True)
   65            (find (\msr -> measureMetric msr == idMetric && measureDatum msr == idMeasureVal) (recordMeasures r))
   66 
   67 lookupVolumeRecords :: MonadDB c m => Volume -> m [Record]
   68 lookupVolumeRecords vol =
   69   dbQuery $ fmap ($ vol) $(selectQuery selectVolumeRecord "$WHERE record.volume = ${volumeId $ volumeRow vol}")
   70 
   71 addRecord :: MonadAudit c m => Record -> m Record
   72 addRecord br = do
   73   ident <- getAuditIdentity
   74   dbQuery1' $(insertRecord 'ident 'br)
   75 
   76 changeRecord :: MonadAudit c m => Record -> m ()
   77 changeRecord r = do
   78   ident <- getAuditIdentity
   79   dbExecute1' $(updateRecord 'ident 'r)
   80 
   81 removeRecord :: MonadAudit c m => Record -> m Bool
   82 removeRecord r = do
   83   ident <- getAuditIdentity
   84   isRight <$> dbTryJust (guard . isForeignKeyViolation) (dbExecute1 $(deleteRecord 'ident 'r))
   85 
   86 recordJSON :: JSON.ToNestedObject o u => Bool -> Record -> JSON.Record (Id Record) o
   87 recordJSON publicRestricted r@Record{ recordRow = RecordRow{..}, ..} = JSON.Record recordId $
   88   -- "volume" JSON..= volumeId recordVolume
   89      "category" JSON..= categoryId recordCategory
   90   <> "measures" JSON..=. measuresJSON publicRestricted (getRecordMeasures r)
   91 
   92 extractParticipantFieldRows :: [BS.ByteString] -> Vector CSV.NamedRecord -> [(BS.ByteString, [BS.ByteString])]
   93 extractParticipantFieldRows participantFieldHeaders records =
   94     (zip participantFieldHeaders . fmap (\hdr -> extractColumnDefaulting hdr records)) participantFieldHeaders
   95 
   96 columnSampleJson :: BS.ByteString -> [BS.ByteString] -> JSON.Value
   97 columnSampleJson hdr sampleValues =
   98     JSON.object [
   99           "column_name" JSON..= hdr
  100         , "samples" JSON..= sampleValues
  101         ]