-- License: BSD3 (see LICENSE) -- Author: Dino Morelli {-# LANGUAGE OverloadedStrings #-} {- This is for constructing and inserting regional statistics data for KitchenSnitch into MongoDB -} import Control.Arrow ( (***) ) import Control.Monad.State import qualified Data.Bson as BSON import Data.Bson.Generic ( fromBSON, toBSON ) import Data.Maybe ( fromJust ) import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Data.Version ( showVersion ) import Database.MongoDB hiding ( options ) import KS.Data.BSON ( combineId, separateId ) import qualified KS.Data.Document as D import qualified KS.Data.Inspection as I import qualified KS.Data.Place as P import Paths_ks_download ( version ) import System.Environment ( getArgs ) import System.Exit ( ExitCode (..), exitWith ) import System.IO ( BufferMode ( NoBuffering ) , hSetBuffering, stdout, stderr ) import Text.Printf ( printf ) import Text.Regex ( mkRegex, subRegex ) import KS.Database.Mongo.Util ( coll_inspections_all, coll_inspections_recent, mongoConnect ) coll_inspections :: Collection coll_inspections = "inspections_datefix" --coll_inspections = "inspections" --coll_inspections = "recent_inspections" main :: IO () main = do -- No buffering, it messes with the order of output mapM_ (flip hSetBuffering NoBuffering) [ stdout, stderr ] printf "ks-misc version %s started\n" (showVersion version) putStrLn "BE VERY CAREFUL WITH THIS UTILITY! It contains one-off, often destructive code that's been used to modify the databases. Run this only if you know what you're doing. You have been warned." (confDir : _) <- getArgs conn@(pipe, _) <- mongoConnect putStrLn confDir --result <- updateRecords conn mapM_ (fixRecents conn) dates close pipe let result = True exitWith . toExitCode $ result dates = [ 20150331 , 20150406 , 20150702 , 20150928 , 20151124 , 20151202 ] fixRecents :: (Pipe, T.Text) -> Int -> IO () fixRecents conn@(pipe, database) date = do -- Find place_idS in inspections_recent for the date recentDocs <- access pipe slaveOk database $ rest =<< find (select ["inspection.date" =: date] coll_inspections_recent) forM_ recentDocs $ \d -> do putStrLn $ "-----\nFixing: " ++ (displayBrief d) let place_id = "place_id" `at` ("place" `at` d) fixRecent conn pipe place_id fixRecent :: (Pipe, T.Text) -> T.Text -> IO () fixRecent (pipe, database) place_id = do -- Get the most recent doc for that place_id from inspections_all latest <- head <$> (access pipe slaveOk database $ rest =<< find (select ["place.place_id" =: place_id] coll_inspections_all) { sort = ["inspection.date" =: (-1 :: Int)] , limit = (1 :: Limit) }) putStrLn $ "Most recent: " ++ (displayBrief latest) putStrLn "Deleting the bad document from inspections_recent" _ <- access pipe slaveOk database $ deleteOne (select ["place.place_id" =: place_id] coll_inspections_recent) putStrLn "Inserting the good document" _ <- access pipe slaveOk database $ insert_ coll_inspections_recent latest return () displayBrief doc = printf "%d %s %s" ("date" `at` ("inspection" `at` doc) :: Int) (T.unpack $ "place_id" `at` ("place" `at` doc)) (T.unpack $ "name" `at` ("place" `at` doc)) type Fix a = (StateT (BSON.Document, D.Document) IO) a runFix :: (BSON.Document, D.Document) -> Fix (BSON.Document, D.Document) -> IO (BSON.Document, D.Document) runFix st ev = execStateT ev st updateRecords :: (Pipe, T.Text) -> IO Bool updateRecords (pipe, database) = do rs <- access pipe slaveOk database $ rest =<< find (select [] coll_inspections) { sort = [ "inspection.date" =: (1 :: Int) ] -- , limit = (50 :: Limit) } -- Take the _id apart and deserialize the rest into a KS Document let ts = map (\r -> (id *** (fromJust . fromBSON)) $ separateId r) rs _ <- forM ts $ (\t -> do (_id, newDoc) <- updateRecord t when (snd t /= newDoc) $ do liftIO $ putStrLn " Document changed, updating" -- write to mongo now let newBSON = combineId (_id, toBSON newDoc) access pipe slaveOk database $ save coll_inspections newBSON ) return True updateRecord :: (BSON.Document, D.Document) -> IO (BSON.Document, D.Document) updateRecord oldDocT = runFix oldDocT $ do display fixHost --fixDate upgradeDate return =<< get updateSnd :: D.Document -> Fix () updateSnd d = do (i, _) <- get put (i, d) display :: Fix () display = do doc <- gets snd let placeID = P.place_id . D.place $ doc let ut = posixSecondsToUTCTime . realToFrac . I.date . D.inspection $ doc let placeName = P.name . D.place $ doc let detail = I.detail . D.inspection $ doc liftIO $ do date <- formatTime defaultTimeLocale "%FT%T%z" <$> utcToLocalZonedTime ut printf "----------\nInspection %s %s %s\n %s\n" (T.unpack placeID) date (T.unpack placeName) detail fixHost :: Fix () fixHost = do oldDoc <- gets snd let oldUrl = I.detail . D.inspection $ oldDoc let newUrl = subRegex (mkRegex "(.*)wake\\.digitalhealthdepartment\\.com(.*)") oldUrl "\\1wake-nc.healthinspections.us\\2" when (oldUrl /= newUrl) $ do let newInsp = (D.inspection oldDoc) { I.detail = newUrl } let newDoc = oldDoc { D.inspection = newInsp } updateSnd newDoc liftIO $ putStrLn " Fixed host" return () fixDate :: Fix () fixDate = do oldDoc <- gets snd let ut = posixSecondsToUTCTime . realToFrac . I.date . D.inspection $ oldDoc zt <- liftIO $ utcToLocalZonedTime ut let oldHour = todHour . localTimeOfDay . zonedTimeToLocalTime $ zt when (oldHour /= 0 && oldHour /= 1) $ do let nextDay = addDays 1 . localDay . zonedTimeToLocalTime $ zt let newZT = ZonedTime (LocalTime nextDay midnight) (zonedTimeZone zt) let newUT = zonedTimeToUTC newZT let newEpoch = round . utcTimeToPOSIXSeconds $ newUT let newInsp = (D.inspection oldDoc) { I.date = newEpoch } let newDoc = oldDoc { D.inspection = newInsp } updateSnd newDoc date <- liftIO $ formatTime defaultTimeLocale "%FT%T%z" <$> utcToLocalZonedTime newUT liftIO $ printf " Fixed date: %s\n" date return () upgradeDate :: Fix () upgradeDate = do oldDoc <- gets snd let ut = posixSecondsToUTCTime . realToFrac . I.date . D.inspection $ oldDoc zt <- liftIO $ utcToLocalZonedTime ut let (y, m, d) = toGregorian . localDay . zonedTimeToLocalTime $ zt let newDate = read $ printf "%d%02d%02d" y m d let newInsp = (D.inspection oldDoc) { I.date = newDate } let newDoc = oldDoc { D.inspection = newInsp } updateSnd newDoc liftIO $ printf " Upgraded date: %s\n" (show newDate) return () toExitCode :: Bool -> ExitCode toExitCode True = ExitSuccess toExitCode False = ExitFailure 1