--- /dev/null
+{- Compute remote.
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Remote.Compute (remote) where
+
+import Annex.Common
+import Types.Remote
+import Types.ProposedAccepted
+import Types.Creds
+import Config
+import Config.Cost
+import Remote.Helper.Special
+import Remote.Helper.ExportImport
+import Annex.SpecialRemote.Config
+import Annex.UUID
+import Logs.RemoteState
+import Utility.Metered
+import qualified Git
+import qualified Utility.SimpleProtocol as Proto
+
+import Control.Concurrent.STM
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+remote :: RemoteType
+remote = RemoteType
+ { typename = "compute"
+ , enumerate = const $ findSpecialRemotes "compute"
+ , generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser programField
+ (FieldDesc $ "compute program (must start with \"" ++ safetyPrefix ++ "\")")
+ ]
+ , setup = setupInstance
+ , exportSupported = exportUnsupported
+ , importSupported = importUnsupported
+ , thirdPartyPopulated = False
+ }
+
+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+gen r u rc gc rs = case getComputeProgram rc of
+ Left _err -> return Nothing
+ Right program -> do
+ interface <- liftIO $ newTMVarIO Nothing
+ c <- parsedRemoteConfig remote rc
+ cst <- remoteCost gc c veryExpensiveRemoteCost
+ return $ Just $ mk program interface c cst
+ where
+ mk program interface c cst = Remote
+ { uuid = u
+ , cost = cst
+ , name = Git.repoDescribe r
+ , storeKey = storeKeyUnsupported
+ , retrieveKeyFile = computeKey program interface
+ , retrieveKeyFileInOrder = pure True
+ , retrieveKeyFileCheap = Nothing
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
+ , removeKey = dropKey rs
+ , lockContent = Nothing
+ , checkPresent = checkKey program interface
+ , checkPresentCheap = False
+ , exportActions = exportUnsupported
+ , importActions = importUnsupported
+ , whereisKey = Nothing
+ , remoteFsck = Nothing
+ , repairRepo = Nothing
+ , config = c
+ , gitconfig = gc
+ , localpath = Nothing
+ , getRepo = return r
+ , readonly = True
+ , appendonly = False
+ , untrustworthy = False
+ , availability = pure LocallyAvailable
+ , remotetype = remote
+ , mkUnavailable = return Nothing
+ , getInfo = return []
+ , claimUrl = Nothing
+ , checkUrl = Nothing
+ , remoteStateHandle = rs
+ }
+
+setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+setupInstance _ mu _ c _ = do
+ ComputeProgram program <- either giveup return (getComputeProgram c)
+ unlessM (liftIO $ inSearchPath program) $
+ giveup $ "Cannot find " ++ program ++ " in PATH"
+ u <- maybe (liftIO genUUID) return mu
+ gitConfigSpecialRemote u c [("compute", "true")]
+ return (c, u)
+
+newtype ComputeProgram = ComputeProgram String
+ deriving (Show)
+
+getComputeProgram :: RemoteConfig -> Either String ComputeProgram
+getComputeProgram c = case fromProposedAccepted <$> M.lookup programField c of
+ Just program
+ | safetyPrefix `isPrefixOf` program ->
+ Right (ComputeProgram program)
+ | otherwise -> Left $
+ "The program's name must begin with \"" ++ safetyPrefix ++ "\""
+ Nothing -> Left "Specify program="
+
+-- Limiting the program to "git-annex-compute-" prefix is important for
+-- security, it prevents autoenabled compute remotes from running arbitrary
+-- programs.
+safetyPrefix :: String
+safetyPrefix = "git-annex-compute-"
+
+programField :: RemoteConfigField
+programField = Accepted "program"
+
+type Name = String
+type Description = String
+type Id = String
+
+data InterfaceItem
+ = InterfaceInput Id Description
+ | InterfaceOptionalInput Id Description
+ | InterfaceValue Name Description
+ | InterfaceOptionalValue Name Description
+ | InterfaceOutput Id Description
+ | InterfaceReproducible
+ deriving (Show, Eq)
+
+-- List order matters, because when displaying the interface to the
+-- user, need to display it in the same order as the program
+-- does.
+data Interface = Interface [InterfaceItem]
+ deriving (Show, Eq)
+
+instance Proto.Receivable InterfaceItem where
+ parseCommand "INPUT" = Proto.parse2 InterfaceInput
+ parseCommand "INPUT?" = Proto.parse2 InterfaceOptionalInput
+ parseCommand "VALUE" = Proto.parse2 InterfaceValue
+ parseCommand "VALUE?" = Proto.parse2 InterfaceOptionalValue
+ parseCommand "OUTPUT" = Proto.parse2 InterfaceOutput
+ parseCommand "REPRODUCIBLE" = Proto.parse0 InterfaceReproducible
+
+getInterface :: ComputeProgram -> TMVar (Maybe Interface) -> IO (Either String Interface)
+getInterface program iv =
+ atomically (takeTMVar iv) >>= \case
+ Nothing -> getInterface' program >>= \case
+ Left err -> do
+ atomically $ putTMVar iv Nothing
+ return (Left err)
+ Right interface -> ret interface
+ Just interface -> ret interface
+ where
+ ret interface = do
+ atomically $ putTMVar iv (Just interface)
+ return (Right interface)
+
+getInterface' :: ComputeProgram -> IO (Either String Interface)
+getInterface' (ComputeProgram program) =
+ catchMaybeIO (readProcess program ["interface"]) >>= \case
+ Nothing -> return $ Left $ "Failed to run " ++ program
+ Just output -> return $ case parseInterface output of
+ Right i -> Right i
+ Left err -> Left $ program ++ " interface output problem: " ++ err
+
+parseInterface :: String -> Either String Interface
+parseInterface = go [] . lines
+ where
+ go is []
+ | null is = Left "empty interface output"
+ | otherwise = Right (Interface (reverse is))
+ go is (l:ls)
+ | null l = go is ls
+ | otherwise = case Proto.parseMessage l of
+ Just i -> go (i:is) ls
+ Nothing -> Left $ "Unable to parse line: \"" ++ l ++ "\""
+
+data ComputeInput = ComputeInput Key FilePath
+ deriving (Show, Eq)
+
+data ComputeValue = ComputeValue String
+
+data ComputeState = ComputeState
+ { computeInputs :: M.Map Id ComputInput
+ , computeValues :: M.Map Id ComputeValue
+ }
+ deriving (Show, Eq)
+
+-- The state is URI encoded.
+--
+-- A ComputeValue with Id "foo" is represented as "vfoo=value"
+-- A ComputeInput with Id "foo" is represented as "kfoo=key&pfoo=path"
+formatComputeState :: ComputeState -> String
+formatComputeState st =
+ map formatinput (computeInputes st)
+ ++ concatMap formatvalue (computeValues st)
+
+parseComputeState :: String -> ComputeState
+parseComputeState =
+
+-- TODO
+computeKey :: ComputeProgram -> TMVar (Maybe Interface) -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
+computeKey program iv key _af dest p vc =
+ liftIO (getInterface program iv) >>= \case
+ Left err -> giveup err
+ Right interface -> undefined
+
+-- TODO Make sure that the remote state meets the program's current
+-- interface.
+checkKey :: ComputeProgram -> TMVar (Maybe Interface) -> Key -> Annex Bool
+checkKey program iv _ =
+ liftIO (getInterface program iv) >>= \case
+ Left err -> giveup err
+ Right interface -> undefined
+
+-- Removing remote state will prevent computing the key.
+dropKey :: RemoteStateHandle -> Maybe SafeDropProof -> Key -> Annex ()
+dropKey rs _ k = setRemoteState rs k mempty
+
+storeKeyUnsupported :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
+storeKeyUnsupported _ _ _ _ = giveup "transfer to compute remote not supported; use git-annex addcomputed instead"
+
If possible, the program should write the content of the file it is
computing directly to the file listed in COMPUTING, rather than writing to
-somewhere else and renaming it at the end. If git-annex sees that the file
-corresponding to the key it requested be computed is growing, it will use
-its file size when displaying progress to the user.
+somewhere else and renaming it at the end. Except, when the program writes
+the file it computes out of order, it should write to a file somewhere else
+and rename it at the end.
+
+If git-annex sees that the file corresponding to the key it requested be
+computed is growing, it will use its file size when displaying progress to
+the user.
The program can also output lines to stdout to indicate its current
-progress.
+progress:
PROGRESS 50%
If the program exits nonzero, nothing it computed will be stored in the
git-annex repository.
-The program must also support listing the inputs and outputs that it
+When run with the "interface" parameter, the program must describe its
+interface. This is a list of the inputs and outputs that it
supports. This allows `git-annex addcomputed` and `git-annex initremote` to
list inputs and outputs, and also lets them reject invalid inputs and
outputs.
-In this mode, the program is run with a "list" parameter.
-It should output lines, in the form:
+The output is lines, in the form:
- INPUT[?] Name Description
- VALUE[?] Name Description
+ INPUT[?] Id Description
+ VALUE[?] Id Description
OUTPUT Id Description
Use "INPUT" when a file is an input to the computation,
and "VALUE" for all other input values. Use "INPUT?" and "VALUE?"
for optional inputs and values.
-The program can also optionally output a "REPRODUCIBLE" line.
+The interface can also optionally include a "REPRODUCIBLE" line.
That indicates that the results of its computations are
expected to be bit-for-bit reproducible.
That makes `git-annex addcomputed` behave as if the `--reproducible`
#!/bin/sh
set -e
- if [ "$1" = list ]; then
+ if [ "$1" = interface ]; then
echo "INPUT raw A photo in RAW format"
echo "VALUE? passes Number of passes"
echo "OUTPUT photo Computed JPEG"
projects / git-annex.git / commitdiff