split rectify and modify as decided in #343

CHANGELOG.md

@@ -1,5 +1,7 @@
+- V 2.3.0.0:
+    - Split the functionality of `rectify` into a new subcommand `modify` that exactly mirrors the former `rectify`, and a new `rectify` that just adds and adjusts checksums and increments version numbers to make recently changed package pass validation again.
 - V 2.2.2.2:
-    - uses newer version of sequence-formats, improving 
+    - Switched to newer version of sequence-formats, improving genotype data parsing error messages.
     - Changed "PoseidonID" to the correct "Poseidon_ID" in an error message and on the server website.
 - V 2.2.2.1:
     - Update of the sequence-formats dependency because of a purely technical build issue on windows, caused by a non-standard directory name.

poseidon-hs.cabal

@@ -1,5 +1,5 @@
 name:                poseidon-hs
-version:             2.2.2.2
+version:             2.3.0.0
 synopsis:            A package with tools for working with Poseidon genotype data
 description:         The tools in this package read and analyse Poseidon-formatted genotype databases, a modular system for storing genotype data from thousands of individuals.
 license:             MIT
@@ -28,7 +28,7 @@ library
                         Poseidon.CLI.Trident.Survey, Poseidon.CLI.Trident.Forge, Poseidon.CLI.Trident.Init,
                         Poseidon.CLI.Trident.Rectify, Poseidon.CLI.Trident.Fetch, Poseidon.CLI.Trident.Genoconvert,
                         Poseidon.CLI.Trident.OptparseApplicativeParsers, Poseidon.CLI.Trident.Timetravel,
-                        Poseidon.CLI.Trident.Jannocoalesce,
+                        Poseidon.CLI.Trident.Jannocoalesce, Poseidon.CLI.Trident.Modify
                         -- analysis
                         Poseidon.Analysis.FStatsConfig, Poseidon.Analysis.RASconfig, Poseidon.Analysis.Utils,
                         Poseidon.Analysis.Generator.Parsers, Poseidon.Analysis.Generator.Types,
@@ -40,7 +40,7 @@ library
     build-depends:      base >= 4.7 && < 5, sequence-formats>=1.6.1, text, time, pipes-safe, foldl,
                         exceptions, pipes, bytestring, filepath, yaml, aeson, directory, parsec,
                         vector, pipes-ordered-zip, table-layout<1.0.0.0, mtl, split, warp, warp-tls, wai-cors,
-                        scotty, cassava, pureMD5, wai, githash, attoparsec, pipes-group,
+                        scotty, cassava, cryptohash-md5, base16-bytestring, wai, githash, attoparsec, pipes-group,
                         http-conduit, conduit, http-types, zip-stream, resourcet, MonadRandom, lens-family,
                         unordered-containers, network-uri, optparse-applicative, co-log, regex-tdfa,
                         scientific, country, generics-sop, containers, process, deepseq, template-haskell,

src-executables/Main-trident.hs

@@ -15,6 +15,8 @@ import           Poseidon.CLI.Trident.Jannocoalesce              (JannoCoalesceO
                                                                   runJannocoalesce)
 import           Poseidon.CLI.Trident.List                       (ListOptions (..),
                                                                   runList)
+import           Poseidon.CLI.Trident.Modify                     (ModifyOptions (..),
+                                                                  runModify)
 import           Poseidon.CLI.Trident.OptparseApplicativeParsers
 import           Poseidon.CLI.Trident.Rectify                    (RectifyOptions (..),
                                                                   runRectify)
@@ -69,6 +71,7 @@ data Subcommand =
     | CmdSummarise SummariseOptions
     | CmdSurvey SurveyOptions
     | CmdRectify RectifyOptions
+    | CmdModify ModifyOptions
     | CmdValidate ValidateOptions
     | CmdChronicle ChronicleOptions
     | CmdTimetravel TimetravelOptions
@@ -98,6 +101,7 @@ runCmd o = case o of
     CmdInit          opts -> runInit opts
     CmdList          opts -> runList opts
     CmdRectify       opts -> runRectify opts
+    CmdModify        opts -> runModify opts
     CmdServe         opts -> runServerMainThread opts
     CmdSummarise     opts -> runSummarise opts
     CmdSurvey        opts -> runSurvey opts
@@ -137,6 +141,7 @@ subcommandParser = OP.subparser (
         OP.command "genoconvert" genoconvertOptInfo <>
         OP.command "jannocoalesce" jannocoalesceOptInfo <>
         OP.command "rectify" rectifyOptInfo <>
+        OP.command "modify" modifyOptInfo <>
         OP.commandGroup "Package creation and manipulation commands:"
     ) <|>
     OP.subparser (
@@ -179,6 +184,8 @@ subcommandParser = OP.subparser (
             ))
     rectifyOptInfo = OP.info (OP.helper <*> (CmdRectify <$> rectifyOptParser))
         (OP.progDesc "Adjust POSEIDON.yml files automatically to package changes")
+    modifyOptInfo = OP.info (OP.helper <*> (CmdModify <$> modifyOptParser))
+        (OP.progDesc "Modify certain elements of Poseidon packages")
     validateOptInfo = OP.info (OP.helper <*> (CmdValidate <$> validateOptParser))
         (OP.progDesc "Check Poseidon packages or package components for structural correctness")
     chronicleOptInfo = OP.info (OP.helper <*> (CmdChronicle <$> chronicleOptParser))
@@ -244,13 +251,19 @@ surveyOptParser = SurveyOptions <$> parseBasePaths
 
 rectifyOptParser :: OP.Parser RectifyOptions
 rectifyOptParser = RectifyOptions <$> parseBasePaths
-                                  <*> parseIgnorePoseidonVersion
-                                  <*> parseMaybePoseidonVersion
                                   <*> parseMaybePackageVersionUpdate
-                                  <*> parseChecksumsToRectify
                                   <*> parseMaybeContributors
-                                  <*> parseJannoRemoveEmptyCols
-                                  <*> parseOnlyLatest
+
+modifyOptParser :: OP.Parser ModifyOptions
+modifyOptParser = ModifyOptions <$> parseBasePaths
+                                <*> parseIgnorePoseidonVersion
+                                <*> parseMaybePoseidonVersion
+                                <*> parseMaybePackageVersionUpdate
+                                <*> parseChecksumsToRectify
+                                <*> parseMaybeContributors
+                                <*> parseJannoRemoveEmptyCols
+                                <*> parseOnlyLatest
+                                <*> parseForce
 
 validateOptParser :: OP.Parser ValidateOptions
 validateOptParser = ValidateOptions <$> parseValidatePlan

src/Poseidon/CLI/Trident/Modify.hs

@@ -0,0 +1,236 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Poseidon.CLI.Trident.Modify (
+    runModify, ModifyOptions (..), PackageVersionUpdate (..), ChecksumsToModify (..),
+    updateChecksums, addContributors, completeAndWritePackage
+    ) where
+
+import           Poseidon.Core.Contributor     (ContributorSpec (..))
+import           Poseidon.Core.EntityTypes     (HasNameAndVersion (..),
+                                                PacNameAndVersion (..),
+                                                renderNameWithVersion)
+import           Poseidon.Core.GenotypeData    (GenotypeDataSpec (..),
+                                                GenotypeFileSpec (..))
+import           Poseidon.Core.Janno           (makeJannoHeader,
+                                                writeJannoFileWithoutEmptyCols)
+import           Poseidon.Core.Package         (PackageReadOptions (..),
+                                                PoseidonPackage (..),
+                                                defaultPackageReadOptions,
+                                                readPoseidonPackageCollection,
+                                                writePoseidonPackage)
+import           Poseidon.Core.PoseidonVersion (PoseidonVersion (..))
+import           Poseidon.Core.Utils           (PoseidonIO, getChk, logDebug,
+                                                logError, logInfo, logWarning)
+import           Poseidon.Core.Version         (VersionComponent (..),
+                                                updateThreeComponentVersion)
+
+import           Control.DeepSeq               ((<$!!>))
+import           Control.Monad                 (when)
+import           Control.Monad.IO.Class        (MonadIO, liftIO)
+import           Data.List                     (nub)
+import           Data.Maybe                    (fromJust)
+import           Data.Time                     (UTCTime (..), getCurrentTime)
+import           Data.Version                  (Version (..), makeVersion,
+                                                showVersion)
+import           System.Directory              (doesFileExist, removeFile)
+import           System.Exit                   (exitFailure)
+import           System.FilePath               ((</>))
+
+data ModifyOptions = ModifyOptions
+    { _modifyBaseDirs              :: [FilePath]
+    , _modifyIgnorePoseidonVersion :: Bool
+    , _modifyPoseidonVersion       :: Maybe Version
+    , _modifyPackageVersionUpdate  :: Maybe PackageVersionUpdate
+    , _modifyChecksums             :: ChecksumsToModify
+    , _modifyNewContributors       :: Maybe [ContributorSpec]
+    , _modifyJannoRemoveEmptyCols  :: Bool
+    , _modifyOnlyLatest            :: Bool
+    , _modifyForce                 :: Bool
+    }
+
+data PackageVersionUpdate = PackageVersionUpdate
+    { _pacVerUpVersionComponent :: VersionComponent
+    , _pacVerUpLog              :: Maybe String
+    }
+
+data ChecksumsToModify =
+    ChecksumNone |
+    ChecksumAll |
+    ChecksumsDetail
+    { _modifyChecksumGeno  :: Bool
+    , _modifyChecksumJanno :: Bool
+    , _modifyChecksumSSF   :: Bool
+    , _modifyChecksumBib   :: Bool
+    }
+
+runModify :: ModifyOptions -> PoseidonIO ()
+runModify (ModifyOptions
+                baseDirs
+                ignorePosVer newPosVer pacVerUpdate checksumUpdate newContributors
+                jannoRemoveEmptyCols
+                onlyLatest force
+           ) = do
+    let pacReadOpts = defaultPackageReadOptions {
+          _readOptIgnoreChecksums  = True
+        , _readOptIgnoreGeno       = True
+        , _readOptGenoCheck        = False
+        , _readOptOnlyLatest       = onlyLatest
+    }
+    allPackages <- readPoseidonPackageCollection
+        pacReadOpts {_readOptIgnorePosVersion = ignorePosVer}
+        baseDirs
+    case allPackages of
+        []  -> do
+            logWarning "No packages found."
+            logInfo "Done"
+        [x] -> do
+            modifyOnePackage x
+            logInfo "Done"
+        xs  -> if force
+               then do
+                   mapM_ modifyOnePackage allPackages
+                   logInfo "Done"
+               else do
+                   logError $ show (length xs) ++
+                              " packages selected for modification.\
+                              \ Run modify with --force if you really want to edit\
+                              \ all of them."
+                   liftIO exitFailure
+    where
+        modifyOnePackage :: PoseidonPackage -> PoseidonIO ()
+        modifyOnePackage inPac = do
+            logInfo $ "Modifying package: " ++ renderNameWithVersion inPac
+            when jannoRemoveEmptyCols $ do
+                case posPacJannoFile inPac of
+                    Nothing   -> do
+                        logWarning "No .janno file to modify with --jannoRemoveEmpty"
+                    Just jannoPath -> do
+                        logInfo "Reordering and removing empty columns from .janno file"
+                        liftIO $ writeJannoFileWithoutEmptyCols
+                                     (posPacBaseDir inPac </> jannoPath)
+                                     (makeJannoHeader (posPacJanno inPac))
+                                     (posPacJanno inPac)
+            updatedPacPosVer <- updatePoseidonVersion newPosVer inPac
+            updatedPacContri <- addContributors newContributors updatedPacPosVer
+            updatedPacChecksums <- updateChecksums checksumUpdate updatedPacContri
+            completeAndWritePackage pacVerUpdate updatedPacChecksums
+
+updatePoseidonVersion :: Maybe Version -> PoseidonPackage -> PoseidonIO PoseidonPackage
+updatePoseidonVersion Nothing    pac = return pac
+updatePoseidonVersion (Just ver) pac = do
+    logDebug "Updating Poseidon version"
+    return pac { posPacPoseidonVersion = PoseidonVersion ver }
+
+addContributors :: Maybe [ContributorSpec] -> PoseidonPackage -> PoseidonIO PoseidonPackage
+addContributors Nothing pac = return pac
+addContributors (Just cs) pac = do
+    logDebug "Updating list of contributors"
+    return pac { posPacContributor = nub (posPacContributor pac ++ cs) }
+
+updateChecksums :: ChecksumsToModify -> PoseidonPackage -> PoseidonIO PoseidonPackage
+updateChecksums checksumSetting pac = do
+    case checksumSetting of
+        ChecksumNone            -> logDebug "Update no checksums" >> return pac
+        ChecksumAll             -> update True True True True
+        ChecksumsDetail g j s b -> update g j s b
+    where
+        update :: Bool -> Bool -> Bool -> Bool -> PoseidonIO PoseidonPackage
+        update g j s b = do
+            let d = posPacBaseDir pac
+            let gFileSpec = genotypeFileSpec . posPacGenotypeData $ pac
+            newGenotypeFileSpec <-
+                if g
+                then do
+                    logDebug "Updating genotype data checksums"
+                    case gFileSpec of
+                        GenotypeEigenstrat gf gfc sf sfc if_ ifc -> do
+                            [genoChkSum, snpChkSum, indChkSum] <-
+                                sequence [testAndGetChecksum (d </> f) c | (f, c) <- zip [gf, sf, if_] [gfc, sfc, ifc]]
+                            return $ GenotypeEigenstrat gf genoChkSum sf snpChkSum if_ indChkSum
+                        GenotypePlink gf gfc sf sfc if_ ifc -> do
+                            [genoChkSum, snpChkSum, indChkSum] <-
+                                sequence [testAndGetChecksum (d </> f) c | (f, c) <- zip [gf, sf, if_] [gfc, sfc, ifc]]
+                            return $ GenotypePlink gf genoChkSum sf snpChkSum if_ indChkSum
+                        GenotypeVCF gf gfc -> do
+                            genoChkSum <- testAndGetChecksum (d </> gf) gfc
+                            return $ GenotypeVCF gf genoChkSum
+                else return gFileSpec
+            newJannoChkSum <-
+                if j
+                then do
+                    logDebug "Updating .janno file checksums"
+                    case posPacJannoFile pac of
+                        Nothing -> return $ posPacJannoFileChkSum pac
+                        Just fn -> Just <$!!> getChk (d </> fn)
+                else return $ posPacJannoFileChkSum pac
+            newSeqSourceChkSum <-
+                if s
+                then do
+                    logDebug "Updating .ssf file checksums"
+                    case posPacSeqSourceFile pac of
+                        Nothing -> return $ posPacSeqSourceFileChkSum pac
+                        Just fn -> Just <$!!> getChk (d </> fn)
+                else return $ posPacSeqSourceFileChkSum pac
+            newBibChkSum <-
+                if b
+                then do
+                    logDebug "Updating .bib file checksums"
+                    case posPacBibFile pac of
+                        Nothing -> return $ posPacBibFileChkSum pac
+                        Just fn -> Just <$!!> getChk (d </> fn)
+                else return $ posPacBibFileChkSum pac
+            let gd = posPacGenotypeData pac
+            return $ pac {
+                    posPacGenotypeData = gd {genotypeFileSpec = newGenotypeFileSpec},
+                    posPacJannoFileChkSum = newJannoChkSum,
+                    posPacSeqSourceFileChkSum = newSeqSourceChkSum,
+                    posPacBibFileChkSum = newBibChkSum
+                }
+        testAndGetChecksum :: (MonadIO m) => FilePath -> Maybe String -> m (Maybe String)
+        testAndGetChecksum file defaultChkSum = do
+            e <- liftIO . doesFileExist $ file
+            if e then Just <$!!> getChk file else return defaultChkSum
+
+
+completeAndWritePackage :: Maybe PackageVersionUpdate -> PoseidonPackage -> PoseidonIO ()
+completeAndWritePackage Nothing pac = do
+    logDebug "Writing modified POSEIDON.yml file"
+    liftIO $ writePoseidonPackage pac
+completeAndWritePackage (Just (PackageVersionUpdate component logText)) pac = do
+    updatedPacPacVer <- updatePackageVersion component pac
+    updatePacChangeLog <- writeOrUpdateChangelogFile logText updatedPacPacVer
+    logDebug "Writing modified POSEIDON.yml file"
+    liftIO $ writePoseidonPackage updatePacChangeLog
+
+updatePackageVersion :: VersionComponent -> PoseidonPackage -> PoseidonIO PoseidonPackage
+updatePackageVersion component pac = do
+    logDebug "Updating package version"
+    (UTCTime today _) <- liftIO getCurrentTime
+    let pacNameAndVer = posPacNameAndVersion pac
+    let outPac = pac {
+        posPacNameAndVersion = pacNameAndVer {panavVersion = maybe (Just $ makeVersion [0, 1, 0])
+                (Just . updateThreeComponentVersion component)
+                (getPacVersion pac)
+            }
+        , posPacLastModified = Just today
+        }
+    return outPac
+
+writeOrUpdateChangelogFile :: Maybe String -> PoseidonPackage -> PoseidonIO PoseidonPackage
+writeOrUpdateChangelogFile Nothing pac = return pac
+writeOrUpdateChangelogFile (Just logText) pac = do
+    case posPacChangelogFile pac of
+        Nothing -> do
+            logDebug "Creating CHANGELOG.md"
+            liftIO $ writeFile (posPacBaseDir pac </> "CHANGELOG.md") $
+                "- V " ++ showVersion (fromJust $ getPacVersion pac) ++ ": " ++
+                logText ++ "\n"
+            return pac { posPacChangelogFile = Just "CHANGELOG.md" }
+        Just x -> do
+            logDebug "Updating CHANGELOG.md"
+            changelogFile <- liftIO $ readFile (posPacBaseDir pac </> x)
+            liftIO $ removeFile (posPacBaseDir pac </> x)
+            liftIO $ writeFile (posPacBaseDir pac </> x) $
+                "- V " ++ showVersion (fromJust $ getPacVersion pac) ++ ": "
+                ++ logText ++ "\n" ++ changelogFile
+            return pac