module Controller.Ingest
( viewIngest
, postIngest
, detectParticipantCSV
, runParticipantUpload
, mappingParser
, buildParticipantRecordAction
, ParticipantStatus(..)
, MeasureUpdateAction(..)
, ParticipantRecordAction(..)
) where
import Control.Arrow (right)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Vector (Vector)
import Data.Word (Word64)
import Network.HTTP.Types (badRequest400)
import Network.Wai.Parse (FileInfo(..))
import System.Posix.FilePath (takeExtension)
import Data.Csv.Contrib (parseCsvWithHeader, getHeaders, removeBomPrefixText)
import qualified JSON
import Ops
import Has
import Model.Category
import Model.Id
import Model.Metric (Metric)
import Model.Ingest
import Model.Permission
import Model.Measure
import Model.Metric
import Model.Party
import Model.Record
import Model.Volume
import Model.VolumeMetric
import Model.Container
import Ingest.Action
import Ingest.JSON
import HTTP.Path.Parser
import HTTP.Form.Deform
import Action.Route
import Action
import Controller.Paths
import Controller.Permission
import Controller.Form
import Controller.Volume
import Store.Types
import View.Form (FormHtml)
import View.Ingest
viewIngest :: ActionRoute (Id Volume)
viewIngest = action GET (pathId </< "ingest") $ \vi -> withAuth $ do
checkMemberADMIN
s <- focusIO getIngestStatus
v <- getVolume PermissionEDIT vi
peeks $ blankForm . htmlIngestForm v s
data ControlIngestRequest =
AbortIngest Bool
| RunIngest Bool Bool (FileInfo JSON.Value)
postIngest :: ActionRoute (Id Volume)
postIngest = multipartAction $ action POST (pathId </< "ingest") $ \vi -> withAuth $ do
checkMemberADMIN
s <- focusIO getIngestStatus
v <- getVolume PermissionEDIT vi
a <- runFormFiles [("json", 16*1024*1024)] (Just $ htmlIngestForm v s) $ do
csrfForm
AbortIngest abort <- AbortIngest <$> ("abort" .:> deform)
abort `unlessReturn` (RunIngest
<$> ("run" .:> deform)
<*> ("overwrite" .:> deform)
<*> ("json" .:> do
(fileInfo :: FileInfo JSON.Value) <- deform
deformCheck
"Must be JSON."
(\f -> fileContentType f `elem` ["text/json", "application/json"] || takeExtension (fileName f) == ".json")
fileInfo))
r <- maybe
(True <$ focusIO abortIngest)
(\(RunIngest r o j) -> runIngest $ right (map (unId . containerId . containerRow)) <$> ingestJSON v (fileContent j) r o)
a
unless r $ result $ response badRequest400 [] ("failed" :: String)
peeks $ otherRouteResponse [] viewIngest (volumeId $ volumeRow v)
maxWidelyAcceptableHttpBodyFileSize :: Word64
maxWidelyAcceptableHttpBodyFileSize = 16*1024*1024
data DetectParticipantCSVRequest = DetectParticipantCSVRequest (FileInfo TL.Text)
detectParticipantCSV :: ActionRoute (Id Volume)
detectParticipantCSV = action POST (pathJSON >/> pathId </< "detectParticipantCSV") $ \vi -> withAuth $ do
v <- getVolume PermissionEDIT vi
(auth :: SiteAuth) <- peek
(store :: Storage) <- peek
DetectParticipantCSVRequest csvFileInfo <-
runFormFiles [("file", maxWidelyAcceptableHttpBodyFileSize)] (Nothing :: Maybe (RequestContext -> FormHtml TL.Text)) $ do
csrfForm
fileInfo :: (FileInfo TL.Text) <- "file" .:> deform
return (DetectParticipantCSVRequest fileInfo)
let uploadFileContents' = (BSL.toStrict . TLE.encodeUtf8 . removeBomPrefixText . fileContent) csvFileInfo
case parseCsvWithHeader uploadFileContents' of
Left err ->
pure (response badRequest400 [] err)
Right (hdrs, records) -> do
metrics <- lookupVolumeParticipantMetrics v
case checkDetermineMapping metrics ((fmap TE.decodeUtf8 . getHeaders) hdrs) uploadFileContents' of
Left err ->
pure (response badRequest400 [] err)
Right participantFieldMapping -> do
let uploadFileName =
uniqueUploadName auth v ((BSC.unpack . fileName) csvFileInfo)
liftIO
(BS.writeFile
((BSC.unpack . getStorageTempParticipantUpload uploadFileName) store)
uploadFileContents')
pure
$ okResponse []
$ JSON.recordEncoding
$ JSON.Record vi
$ "csv_upload_id" JSON..= uploadFileName
<> "column_samples" JSON..= extractColumnsDistinctSampleJson 5 hdrs records
<> "suggested_mapping" JSON..= participantFieldMappingToJSON participantFieldMapping
<> "columns_firstvals" JSON..= extractColumnsInitialJson 5 hdrs records
uniqueUploadName :: SiteAuth -> Volume -> String -> String
uniqueUploadName siteAuth vol uploadName =
uniqueUploadName'
((partyId . partyRow . accountParty . siteAccount) siteAuth)
((volumeId . volumeRow) vol)
uploadName
uniqueUploadName' :: Id Party -> Id Volume -> String -> String
uniqueUploadName' uid vid uploadName =
show uid <> "-" <> show vid <> "-" <> uploadName
data RunParticipantUploadRequest = RunParticipantUploadRequest String JSON.Value
runParticipantUpload :: ActionRoute (Id Volume)
runParticipantUpload = action POST (pathJSON >/> pathId </< "runParticipantUpload") $ \vi -> withAuth $ do
v <- getVolume PermissionEDIT vi
(store :: Storage) <- peek
RunParticipantUploadRequest csvUploadId selectedMapping <- runForm Nothing $ do
csrfForm
(uploadId :: String) <- "csv_upload_id" .:> deform
mapping <- "selected_mapping" .:> deform
pure (RunParticipantUploadRequest uploadId mapping)
uploadFileContents <-
(liftIO . BS.readFile) ((BSC.unpack . getStorageTempParticipantUpload csvUploadId) store)
case JSON.parseEither mappingParser selectedMapping of
Left err ->
pure (response badRequest400 [] err)
Right mpngVal -> do
participantActiveMetrics <- lookupVolumeParticipantMetrics v
case parseParticipantFieldMapping participantActiveMetrics mpngVal of
Left err ->
pure (response badRequest400 [] err)
Right mpngs ->
case attemptParseRows mpngs uploadFileContents of
Left err ->
pure (response badRequest400 [] err)
Right (_, records) ->
let response' =
okResponse []
$ JSON.recordEncoding
$ JSON.Record vi
$ "succeeded"
JSON..= True
in response' <$ runImport v records
mappingParser :: JSON.Value -> JSON.Parser [(Metric, Text)]
mappingParser val = do
(entries :: [HeaderMappingEntry]) <- JSON.parseJSON val
pure (fmap (\e -> (hmeMetric e, hmeCsvField e)) entries)
runImport :: Volume -> Vector ParticipantRecord -> Handler (Vector ())
runImport vol records =
mapM (createOrUpdateRecord vol) records
data ParticipantStatus = Create | Found Record
data MeasureUpdateAction = Upsert Metric MeasureDatum | Delete Metric | Unchanged Metric | NoAction Metric
deriving (Show, Eq)
data ParticipantRecordAction = ParticipantRecordAction ParticipantStatus [MeasureUpdateAction]
buildParticipantRecordAction :: ParticipantRecord -> ParticipantStatus -> ParticipantRecordAction
buildParticipantRecordAction participantRecord updatingRecord =
let
mId = getFieldVal' prdId participantMetricId
mInfo = getFieldVal' prdInfo participantMetricInfo
mDescription = getFieldVal' prdDescription participantMetricDescription
mBirthdate = getFieldVal' prdBirthdate participantMetricBirthdate
mGender = getFieldVal' prdGender participantMetricGender
mRace = getFieldVal' prdRace participantMetricRace
mEthnicity = getFieldVal' prdEthnicity participantMetricEthnicity
mGestationalAge = getFieldVal' prdGestationalAge participantMetricGestationalAge
mPregnancyTerm = getFieldVal' prdPregnancyTerm participantMetricPregnancyTerm
mBirthWeight = getFieldVal' prdBirthWeight participantMetricBirthWeight
mDisability = getFieldVal' prdDisability participantMetricDisability
mLanguage = getFieldVal' prdLanguage participantMetricLanguage
mCountry = getFieldVal' prdCountry participantMetricCountry
mState = getFieldVal' prdState participantMetricState
mSetting = getFieldVal' prdSetting participantMetricSetting
measureActions =
[ changeRecordMeasureIfUsed mId
, changeRecordMeasureIfUsed mInfo
, changeRecordMeasureIfUsed mDescription
, changeRecordMeasureIfUsed mBirthdate
, changeRecordMeasureIfUsed mGender
, changeRecordMeasureIfUsed mRace
, changeRecordMeasureIfUsed mEthnicity
, changeRecordMeasureIfUsed mGestationalAge
, changeRecordMeasureIfUsed mPregnancyTerm
, changeRecordMeasureIfUsed mBirthWeight
, changeRecordMeasureIfUsed mDisability
, changeRecordMeasureIfUsed mLanguage
, changeRecordMeasureIfUsed mCountry
, changeRecordMeasureIfUsed mState
, changeRecordMeasureIfUsed mSetting
]
in
ParticipantRecordAction updatingRecord (catMaybes measureActions)
where
changeRecordMeasureIfUsed :: Maybe (Maybe MeasureDatum, Metric) -> Maybe MeasureUpdateAction
changeRecordMeasureIfUsed mValueMetric = do
(mVal, met) <- mValueMetric
pure (determineUpdatedMeasure mVal met)
determineUpdatedMeasure :: Maybe MeasureDatum -> Metric -> MeasureUpdateAction
determineUpdatedMeasure mVal met =
case updatingRecord of
Create ->
maybe (NoAction met) (Upsert met) mVal
Found _ -> do
let measureAction = maybe (Delete met) (Upsert met) mVal
measureAction
getFieldVal' :: (ParticipantRecord -> FieldUse a) -> Metric -> Maybe (Maybe MeasureDatum, Metric)
getFieldVal' = getFieldVal participantRecord
getFieldVal
:: ParticipantRecord
-> (ParticipantRecord -> FieldUse a)
-> Metric
-> Maybe (Maybe MeasureDatum, Metric)
getFieldVal participantRecord extractFieldVal metric =
case extractFieldVal participantRecord of
Field fieldVal _ -> pure (Just fieldVal, metric)
FieldEmpty -> pure (Nothing, metric)
FieldUnused -> Nothing
createOrUpdateRecord :: Volume -> ParticipantRecord -> Handler ()
createOrUpdateRecord vol participantRecord = do
let category = getCategory' (Id 1)
mIdVal = fst $ maybe (error "id missing") id (getFieldVal' prdId participantMetricId)
idVal = maybe (error "id empty") id mIdVal
mOldParticipant <- lookupVolumeParticipant vol idVal
let recordStatus =
case mOldParticipant of
Nothing -> Create
Just oldParticipant -> Found oldParticipant
case buildParticipantRecordAction participantRecord recordStatus of
ParticipantRecordAction Create measureActs -> do
newParticipantShell <- addRecord (blankRecord category vol)
_ <- mapM (runMeasureUpdate newParticipantShell) measureActs
pure ()
ParticipantRecordAction (Found oldRecord) measureActs -> do
_ <- mapM (runMeasureUpdate oldRecord) measureActs
pure ()
where
runMeasureUpdate :: Record -> MeasureUpdateAction -> Handler (Maybe Record)
runMeasureUpdate record act =
case act of
Upsert met val -> changeRecordMeasure (Measure record met val)
Delete met -> fmap Just (removeRecordMeasure (Measure record met ""))
Unchanged _ -> pure Nothing
NoAction _ -> pure Nothing
getFieldVal' :: (ParticipantRecord -> FieldUse a) -> Metric -> Maybe (Maybe MeasureDatum, Metric)
getFieldVal' = getFieldVal participantRecord