diff --git a/Command/AddComputed.hs b/Command/AddComputed.hs index d80fb168da..01a334bf9e 100644 --- a/Command/AddComputed.hs +++ b/Command/AddComputed.hs @@ -20,8 +20,9 @@ import Annex.Ingest import Types.RemoteConfig import Types.KeySource import Messages.Progress -import Utility.MonotonicClock import Logs.Location +import Utility.MonotonicClock +import Backend.URL (fromUrl) import qualified Data.Map as M import Data.Time.Clock @@ -42,19 +43,19 @@ optParser :: CmdParamsDesc -> Parser AddComputedOptions optParser desc = AddComputedOptions <$> cmdParams desc <*> (mkParseRemoteOption <$> parseToOption) - <*> (fromMaybe Unreproducible <$> parseReproducible) + <*> (fromMaybe (Reproducible False) <$> parseReproducible) -data Reproducible = Reproducible | Unreproducible +newtype Reproducible = Reproducible { isReproducible :: Bool } parseReproducible :: Parser (Maybe Reproducible) parseReproducible = r <|> unr where - r = flag Nothing (Just Reproducible) + r = flag Nothing (Just (Reproducible True)) ( long "reproducible" <> short 'r' <> help "computation is fully reproducible" ) - unr = flag Nothing (Just Unreproducible) + unr = flag Nothing (Just (Reproducible False)) ( long "unreproducible" <> short 'u' <> help "computation is not fully reproducible" @@ -90,17 +91,14 @@ perform o r program = do , Remote.Compute.computeInputs = mempty , Remote.Compute.computeOutputs = mempty , Remote.Compute.computeSubdir = subdir - , Remote.Compute.computeReproducible = - case reproducible o of - Reproducible -> True - Unreproducible -> False + , Remote.Compute.computeReproducible = isreproducible } fast <- Annex.getRead Annex.fast starttime <- liftIO currentMonotonicTimestamp Remote.Compute.runComputeProgram program state (Remote.Compute.ImmutableState False) (getinputcontent fast) - (go starttime) + (go starttime fast) next $ return True where getinputcontent fast p = catKeyFile p >>= \case @@ -117,7 +115,7 @@ perform o r program = do , giveup $ "The computation needs an input file which does not exist: " ++ fromOsPath p ) - go starttime state tmpdir = do + go starttime fast state tmpdir = do endtime <- liftIO currentMonotonicTimestamp let ts = calcduration starttime endtime let outputs = Remote.Compute.computeOutputs state @@ -125,7 +123,7 @@ perform o r program = do giveup "The computation succeeded, but it did not generate any files." oks <- forM (M.keys outputs) $ \outputfile -> do showAction $ "adding " <> QuotedPath outputfile - k <- catchNonAsync (addfile tmpdir outputfile) + k <- catchNonAsync (addfile fast state tmpdir outputfile) (\err -> giveup $ "Failed to ingest output file " ++ fromOsPath outputfile ++ ": " ++ show err) return (outputfile, Just k) let state' = state @@ -137,24 +135,32 @@ perform o r program = do k ts state' logChange NoLiveUpdate k (Remote.uuid r) InfoPresent - addfile tmpdir outputfile = do - let outputfile' = tmpdir outputfile - let ld = LockedDown ldc $ KeySource - { keyFilename = outputfile - , contentLocation = outputfile' - , inodeCache = Nothing - } - sz <- liftIO $ getFileSize outputfile' - metered Nothing sz Nothing $ \_ p -> - ingestAdd p (Just ld) >>= \case - Nothing -> giveup "key generation failed" - Just k -> return k + addfile fast state tmpdir outputfile + | fast || not isreproducible = do + let stateurl = Remote.Compute.computeStateUrl state outputfile + let k = fromUrl stateurl Nothing isreproducible + addSymlink outputfile k Nothing + return k + | otherwise = do + let outputfile' = tmpdir outputfile + let ld = LockedDown ldc $ KeySource + { keyFilename = outputfile + , contentLocation = outputfile' + , inodeCache = Nothing + } + sz <- liftIO $ getFileSize outputfile' + metered Nothing sz Nothing $ \_ p -> + ingestAdd p (Just ld) >>= \case + Nothing -> giveup "key generation failed" + Just k -> return k ldc = LockDownConfig { lockingFile = True , hardlinkFileTmpDir = Nothing , checkWritePerms = True } - + calcduration (MonotonicTimestamp starttime) (MonotonicTimestamp endtime) = fromIntegral (endtime - starttime) :: NominalDiffTime + + isreproducible = isReproducible (reproducible o) diff --git a/Remote/Compute.hs b/Remote/Compute.hs index cb2bd1f479..1157ac581d 100644 --- a/Remote/Compute.hs +++ b/Remote/Compute.hs @@ -12,6 +12,7 @@ module Remote.Compute ( ComputeState(..), setComputeState, getComputeStates, + computeStateUrl, ComputeProgram, getComputeProgram, runComputeProgram, @@ -36,6 +37,7 @@ import Utility.Metered import Utility.TimeStamp import Utility.Env import Utility.Tmp.Dir +import Utility.Url import qualified Git import qualified Utility.SimpleProtocol as Proto @@ -190,7 +192,10 @@ data ComputeState = ComputeState - and computeOutputs are sorted in ascending order for stability. -} formatComputeState :: Key -> ComputeState -> B.ByteString -formatComputeState k st = renderQuery False $ concat +formatComputeState k = formatComputeState' (Just k) + +formatComputeState' :: Maybe Key -> ComputeState -> B.ByteString +formatComputeState' mk st = renderQuery False $ concat [ map formatparam (computeParams st) , map formatinput (M.toAscList (computeInputs st)) , mapMaybe formatoutput (M.toAscList (computeOutputs st)) @@ -202,7 +207,7 @@ formatComputeState k st = renderQuery False $ concat ("i" <> fromOsPath file, Just (serializeKey' key)) formatoutput (file, (Just key)) = Just $ ("o" <> fromOsPath file, - if key == k + if Just key == mk then Nothing else Just (serializeKey' key) ) @@ -251,6 +256,17 @@ parseComputeState k b = _ -> Nothing in go c' rest +{- A compute: url for a given output file of a computation. -} +computeStateUrl :: ComputeState -> OsPath -> URLString +computeStateUrl st p = + "annex-compute:" ++ fromOsPath p ++ "?" + ++ decodeBS (formatComputeState' Nothing st') + where + -- Omit computeOutputs, so this gives the same result whether + -- it's called on a ComputeState with the computeOutputs + -- Keys populated or not. + st' = st { computeOutputs = mempty } + {- The per remote metadata is used to store ComputeState. This allows - recording multiple ComputeStates that generate the same key. - diff --git a/doc/git-annex-addcomputed.mdwn b/doc/git-annex-addcomputed.mdwn index bca6e1144d..9f096770b7 100644 --- a/doc/git-annex-addcomputed.mdwn +++ b/doc/git-annex-addcomputed.mdwn @@ -54,7 +54,7 @@ Some examples of how this might look: * `--fast` Adds computed files to the repository, without generating their content - yet. + yet. * `--unreproducible`, `-u`