1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Ingest 3 ( viewIngest 4 , postIngest 5 , detectParticipantCSV 6 , runParticipantUpload 7 -- for tests 8 , mappingParser 9 , buildParticipantRecordAction 10 , ParticipantStatus(..) 11 , MeasureUpdateAction(..) 12 , ParticipantRecordAction(..) 13 ) where 14 15 import Control.Arrow (right) 16 import Control.Monad (unless) 17 import Control.Monad.IO.Class (liftIO) 18 import qualified Data.ByteString as BS 19 import qualified Data.ByteString.Char8 as BSC 20 import qualified Data.ByteString.Lazy as BSL 21 import Data.Maybe (catMaybes) 22 import Data.Monoid ((<>)) 23 import Data.Text (Text) 24 import qualified Data.Text.Encoding as TE 25 import qualified Data.Text.Lazy as TL 26 import qualified Data.Text.Lazy.Encoding as TLE 27 import Data.Vector (Vector) 28 import Data.Word (Word64) 29 import Network.HTTP.Types (badRequest400) 30 import Network.Wai.Parse (FileInfo(..)) 31 import System.Posix.FilePath (takeExtension) 32 33 import Data.Csv.Contrib (parseCsvWithHeader, getHeaders, removeBomPrefixText) 34 import qualified JSON 35 import Ops 36 import Has 37 import Model.Category 38 import Model.Id 39 import Model.Metric (Metric) 40 import Model.Ingest 41 import Model.Permission 42 import Model.Measure 43 import Model.Metric 44 import Model.Party 45 import Model.Record 46 import Model.Volume 47 import Model.VolumeMetric 48 import Model.Container 49 import Ingest.Action 50 import Ingest.JSON 51 import HTTP.Path.Parser 52 import HTTP.Form.Deform 53 import Action.Route 54 import Action 55 import Controller.Paths 56 import Controller.Permission 57 import Controller.Form 58 import Controller.Volume 59 import Store.Types 60 import View.Form (FormHtml) 61 import View.Ingest 62 63 viewIngest :: ActionRoute (Id Volume) 64 viewIngest = action GET (pathId </< "ingest") $ \vi -> withAuth $ do 65 checkMemberADMIN 66 s <- focusIO getIngestStatus 67 v <- getVolume PermissionEDIT vi 68 peeks $ blankForm . htmlIngestForm v s 69 70 data ControlIngestRequest = 71 AbortIngest Bool 72 | RunIngest Bool Bool (FileInfo JSON.Value) 73 74 postIngest :: ActionRoute (Id Volume) 75 postIngest = multipartAction $ action POST (pathId </< "ingest") $ \vi -> withAuth $ do 76 checkMemberADMIN 77 s <- focusIO getIngestStatus 78 v <- getVolume PermissionEDIT vi 79 a <- runFormFiles [("json", 16*1024*1024)] (Just $ htmlIngestForm v s) $ do 80 csrfForm 81 AbortIngest abort <- AbortIngest <$> ("abort" .:> deform) 82 abort `unlessReturn` (RunIngest 83 <$> ("run" .:> deform) 84 <*> ("overwrite" .:> deform) 85 <*> ("json" .:> do 86 (fileInfo :: FileInfo JSON.Value) <- deform 87 deformCheck 88 "Must be JSON." 89 (\f -> fileContentType f `elem` ["text/json", "application/json"] || takeExtension (fileName f) == ".json") 90 fileInfo)) 91 r <- maybe 92 (True <$ focusIO abortIngest) 93 (\(RunIngest r o j) -> runIngest $ right (map (unId . containerId . containerRow)) <$> ingestJSON v (fileContent j) r o) 94 a 95 unless r $ result $ response badRequest400 [] ("failed" :: String) 96 peeks $ otherRouteResponse [] viewIngest (volumeId $ volumeRow v) 97 98 maxWidelyAcceptableHttpBodyFileSize :: Word64 99 maxWidelyAcceptableHttpBodyFileSize = 16*1024*1024 100 101 data DetectParticipantCSVRequest = DetectParticipantCSVRequest (FileInfo TL.Text) 102 103 -- TODO: maybe put csv file save/retrieve in Store module 104 detectParticipantCSV :: ActionRoute (Id Volume) 105 detectParticipantCSV = action POST (pathJSON >/> pathId </< "detectParticipantCSV") $ \vi -> withAuth $ do 106 v <- getVolume PermissionEDIT vi 107 (auth :: SiteAuth) <- peek 108 (store :: Storage) <- peek 109 DetectParticipantCSVRequest csvFileInfo <- 110 -- TODO: is Nothing okay here? 111 runFormFiles [("file", maxWidelyAcceptableHttpBodyFileSize)] (Nothing :: Maybe (RequestContext -> FormHtml TL.Text)) $ do 112 csrfForm 113 fileInfo :: (FileInfo TL.Text) <- "file" .:> deform 114 return (DetectParticipantCSVRequest fileInfo) 115 -- liftIO (print ("after extract form")) 116 let uploadFileContents' = (BSL.toStrict . TLE.encodeUtf8 . removeBomPrefixText . fileContent) csvFileInfo 117 -- liftIO (print "uploaded contents below") 118 -- liftIO (print uploadFileContents') 119 case parseCsvWithHeader uploadFileContents' of 120 Left err -> 121 pure (response badRequest400 [] err) 122 Right (hdrs, records) -> do 123 metrics <- lookupVolumeParticipantMetrics v 124 -- liftIO (print ("before check determine", show hdrs)) 125 case checkDetermineMapping metrics ((fmap TE.decodeUtf8 . getHeaders) hdrs) uploadFileContents' of 126 Left err -> 127 -- if column check failed, then don't save csv file and response is error 128 pure (response badRequest400 [] err) 129 Right participantFieldMapping -> do 130 let uploadFileName = 131 uniqueUploadName auth v ((BSC.unpack . fileName) csvFileInfo) 132 liftIO 133 (BS.writeFile 134 ((BSC.unpack . getStorageTempParticipantUpload uploadFileName) store) 135 uploadFileContents') 136 pure 137 $ okResponse [] 138 $ JSON.recordEncoding -- TODO: not record encoding 139 $ JSON.Record vi 140 $ "csv_upload_id" JSON..= uploadFileName 141 -- TODO: samples for mapped columns only 142 <> "column_samples" JSON..= extractColumnsDistinctSampleJson 5 hdrs records 143 <> "suggested_mapping" JSON..= participantFieldMappingToJSON participantFieldMapping 144 <> "columns_firstvals" JSON..= extractColumnsInitialJson 5 hdrs records 145 146 -- TODO: move this to Store.ParticipantUploadTemp 147 uniqueUploadName :: SiteAuth -> Volume -> String -> String 148 uniqueUploadName siteAuth vol uploadName = 149 uniqueUploadName' 150 ((partyId . partyRow . accountParty . siteAccount) siteAuth) 151 ((volumeId . volumeRow) vol) 152 uploadName 153 154 uniqueUploadName' :: Id Party -> Id Volume -> String -> String 155 uniqueUploadName' uid vid uploadName = 156 show uid <> "-" <> show vid <> "-" <> uploadName 157 ----- end 158 159 data RunParticipantUploadRequest = RunParticipantUploadRequest String JSON.Value 160 161 runParticipantUpload :: ActionRoute (Id Volume) 162 runParticipantUpload = action POST (pathJSON >/> pathId </< "runParticipantUpload") $ \vi -> withAuth $ do 163 v <- getVolume PermissionEDIT vi 164 (store :: Storage) <- peek 165 -- reqCtxt <- peek 166 RunParticipantUploadRequest csvUploadId selectedMapping <- runForm Nothing $ do 167 csrfForm 168 (uploadId :: String) <- "csv_upload_id" .:> deform 169 mapping <- "selected_mapping" .:> deform 170 pure (RunParticipantUploadRequest uploadId mapping) 171 -- TODO: resolve csv id to absolute path; http error if unknown 172 uploadFileContents <- 173 (liftIO . BS.readFile) ((BSC.unpack . getStorageTempParticipantUpload csvUploadId) store) 174 case JSON.parseEither mappingParser selectedMapping of 175 Left err -> 176 pure (response badRequest400 [] err) -- bad json shape or keys 177 Right mpngVal -> do 178 participantActiveMetrics <- lookupVolumeParticipantMetrics v 179 case parseParticipantFieldMapping participantActiveMetrics mpngVal of 180 Left err -> 181 pure (response badRequest400 [] err) -- mapping of inactive metrics or missing metric 182 Right mpngs -> 183 case attemptParseRows mpngs uploadFileContents of 184 Left err -> -- invalid value in row 185 pure (response badRequest400 [] err) 186 Right (_, records) -> 187 let response' = 188 okResponse [] 189 $ JSON.recordEncoding -- TODO: not record encoding 190 $ JSON.Record vi 191 $ "succeeded" 192 JSON..= True 193 in response' <$ runImport v records 194 195 mappingParser :: JSON.Value -> JSON.Parser [(Metric, Text)] 196 mappingParser val = do 197 (entries :: [HeaderMappingEntry]) <- JSON.parseJSON val 198 pure (fmap (\e -> (hmeMetric e, hmeCsvField e)) entries) 199 200 -- TODO: move all below to Model.Ingest 201 -- TODO: error or count 202 runImport :: Volume -> Vector ParticipantRecord -> Handler (Vector ()) 203 runImport vol records = 204 mapM (createOrUpdateRecord vol) records 205 206 data ParticipantStatus = Create | Found Record 207 208 data MeasureUpdateAction = Upsert Metric MeasureDatum | Delete Metric | Unchanged Metric | NoAction Metric 209 deriving (Show, Eq) 210 211 data ParticipantRecordAction = ParticipantRecordAction ParticipantStatus [MeasureUpdateAction] 212 213 buildParticipantRecordAction :: ParticipantRecord -> ParticipantStatus -> ParticipantRecordAction 214 buildParticipantRecordAction participantRecord updatingRecord = 215 let 216 mId = getFieldVal' prdId participantMetricId 217 mInfo = getFieldVal' prdInfo participantMetricInfo 218 mDescription = getFieldVal' prdDescription participantMetricDescription 219 mBirthdate = getFieldVal' prdBirthdate participantMetricBirthdate 220 mGender = getFieldVal' prdGender participantMetricGender 221 mRace = getFieldVal' prdRace participantMetricRace 222 mEthnicity = getFieldVal' prdEthnicity participantMetricEthnicity 223 mGestationalAge = getFieldVal' prdGestationalAge participantMetricGestationalAge 224 mPregnancyTerm = getFieldVal' prdPregnancyTerm participantMetricPregnancyTerm 225 mBirthWeight = getFieldVal' prdBirthWeight participantMetricBirthWeight 226 mDisability = getFieldVal' prdDisability participantMetricDisability 227 mLanguage = getFieldVal' prdLanguage participantMetricLanguage 228 mCountry = getFieldVal' prdCountry participantMetricCountry 229 mState = getFieldVal' prdState participantMetricState 230 mSetting = getFieldVal' prdSetting participantMetricSetting 231 -- print ("save measure id:", mId) 232 measureActions = 233 [ changeRecordMeasureIfUsed mId 234 , changeRecordMeasureIfUsed mInfo 235 , changeRecordMeasureIfUsed mDescription 236 , changeRecordMeasureIfUsed mBirthdate 237 , changeRecordMeasureIfUsed mGender 238 , changeRecordMeasureIfUsed mRace 239 , changeRecordMeasureIfUsed mEthnicity 240 , changeRecordMeasureIfUsed mGestationalAge 241 , changeRecordMeasureIfUsed mPregnancyTerm 242 , changeRecordMeasureIfUsed mBirthWeight 243 , changeRecordMeasureIfUsed mDisability 244 , changeRecordMeasureIfUsed mLanguage 245 , changeRecordMeasureIfUsed mCountry 246 , changeRecordMeasureIfUsed mState 247 , changeRecordMeasureIfUsed mSetting 248 ] 249 in 250 ParticipantRecordAction updatingRecord (catMaybes measureActions) 251 where 252 changeRecordMeasureIfUsed :: Maybe (Maybe MeasureDatum, Metric) -> Maybe MeasureUpdateAction 253 changeRecordMeasureIfUsed mValueMetric = do 254 (mVal, met) <- mValueMetric 255 pure (determineUpdatedMeasure mVal met) 256 determineUpdatedMeasure :: Maybe MeasureDatum -> Metric -> MeasureUpdateAction 257 determineUpdatedMeasure mVal met = 258 case updatingRecord of 259 Create -> 260 maybe (NoAction met) (Upsert met) mVal 261 Found _ -> do 262 -- TODO: 263 -- mOldVal <- getOldVal metric record 264 -- action = maybe (Upsert val) (\o -> if o == val then Unchanged else Upsert val) 265 let measureAction = maybe (Delete met) (Upsert met) mVal 266 measureAction 267 getFieldVal' :: (ParticipantRecord -> FieldUse a) -> Metric -> Maybe (Maybe MeasureDatum, Metric) 268 getFieldVal' = getFieldVal participantRecord 269 270 getFieldVal 271 :: ParticipantRecord 272 -> (ParticipantRecord -> FieldUse a) 273 -> Metric 274 -> Maybe (Maybe MeasureDatum, Metric) 275 getFieldVal participantRecord extractFieldVal metric = 276 case extractFieldVal participantRecord of 277 Field fieldVal _ -> pure (Just fieldVal, metric) 278 FieldEmpty -> pure (Nothing, metric) 279 FieldUnused -> Nothing 280 -- field isn't used by this volume, so don't need to save the measure 281 282 createOrUpdateRecord :: Volume -> ParticipantRecord -> Handler () -- TODO: error or record 283 createOrUpdateRecord vol participantRecord = do 284 let category = getCategory' (Id 1) -- TODO: use global variable 285 mIdVal = fst $ maybe (error "id missing") id (getFieldVal' prdId participantMetricId) 286 idVal = maybe (error "id empty") id mIdVal 287 mOldParticipant <- lookupVolumeParticipant vol idVal 288 let recordStatus = 289 case mOldParticipant of 290 Nothing -> Create 291 Just oldParticipant -> Found oldParticipant 292 -- print ("save measure id:", mId) 293 case buildParticipantRecordAction participantRecord recordStatus of 294 ParticipantRecordAction Create measureActs -> do 295 newParticipantShell <- addRecord (blankRecord category vol) -- blankParticipantRecord 296 _ <- mapM (runMeasureUpdate newParticipantShell) measureActs 297 pure () -- TODO: reload participant 298 ParticipantRecordAction (Found oldRecord) measureActs -> do 299 _ <- mapM (runMeasureUpdate oldRecord) measureActs 300 pure () 301 where 302 runMeasureUpdate :: Record -> MeasureUpdateAction -> Handler (Maybe Record) 303 runMeasureUpdate record act = 304 case act of 305 Upsert met val -> changeRecordMeasure (Measure record met val) 306 Delete met -> fmap Just (removeRecordMeasure (Measure record met "")) 307 Unchanged _ -> pure Nothing 308 NoAction _ -> pure Nothing 309 getFieldVal' :: (ParticipantRecord -> FieldUse a) -> Metric -> Maybe (Maybe MeasureDatum, Metric) 310 getFieldVal' = getFieldVal participantRecord