diff options
21 files changed, 751 insertions, 465 deletions
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 144b236a4..3f3823664 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -15,6 +15,7 @@ import Assistant.MakeRemote import Assistant.Sync import Config.Cost import Config +import qualified Types.Remote as Remote import Network.Socket import qualified Data.Text as T @@ -46,7 +47,7 @@ finishedLocalPairing msg keypair = do ] Nothing r <- liftAnnex $ addRemote $ makeSshRemote sshdata - liftAnnex $ setRemoteCost r semiExpensiveRemoteCost + liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost syncRemote r {- Mostly a straightforward conversion. Except: @@ -12,7 +12,6 @@ import qualified Git import qualified Git.Config import qualified Git.Command import qualified Annex -import qualified Types.Remote as Remote import Config.Cost type UnqualifiedConfigKey = String @@ -55,14 +54,16 @@ annexConfig key = ConfigKey $ "annex." ++ key - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command - is set and prints a number, that is used. -} remoteCost :: RemoteGitConfig -> Cost -> Annex Cost -remoteCost c def = case remoteAnnexCostCommand c of +remoteCost c def = fromMaybe def <$> remoteCost' c + +remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost) +remoteCost' c = case remoteAnnexCostCommand c of Just cmd | not (null cmd) -> liftIO $ - (fromMaybe def . readish) <$> - readProcess "sh" ["-c", cmd] - _ -> return $ fromMaybe def $ remoteAnnexCost c + readish <$> readProcess "sh" ["-c", cmd] + _ -> return $ remoteAnnexCost c -setRemoteCost :: Remote -> Cost -> Annex () -setRemoteCost r c = setConfig (remoteConfig (Remote.repo r) "cost") (show c) +setRemoteCost :: Git.Repo -> Cost -> Annex () +setRemoteCost r c = setConfig (remoteConfig r "cost") (show c) getNumCopies :: Maybe Int -> Annex Int getNumCopies (Just v) = return v diff --git a/Remote/External.hs b/Remote/External.hs index c3297c7ea..ae026ca1f 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -5,15 +5,12 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} - module Remote.External (remote) where -import Data.Char - +import Remote.External.Types +import qualified Annex import Common.Annex import Types.Remote -import Types.Key import qualified Git import Config import Remote.Helper.Special @@ -22,30 +19,39 @@ import Crypto import Utility.Metered import Logs.Transfer import Config.Cost +import Annex.Content +import Annex.UUID +import Annex.Exception + +import Control.Concurrent.STM +import System.Process (std_in, std_out, std_err) +import qualified Data.Map as M remote :: RemoteType remote = RemoteType { - typename = "hook", - enumerate = findSpecialRemotes "hooktype", + typename = "external", + enumerate = findSpecialRemotes "externaltype", generate = gen, - setup = undefined + setup = externalSetup } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do - cst <- remoteCost gc expensiveRemoteCost + external <- newExternal externaltype + Annex.addCleanup (fromUUID u) $ stopExternal external + cst <- getCost external r gc return $ Just $ encryptableRemote c - (storeEncrypted $ getGpgEncParams (c,gc)) - retrieveEncrypted + (storeEncrypted external $ getGpgEncParams (c,gc)) + (retrieveEncrypted external) Remote { uuid = u, cost = cst, name = Git.repoDescribe r, - storeKey = store, - retrieveKeyFile = retrieve, + storeKey = store external, + retrieveKeyFile = retrieve external, retrieveKeyFileCheap = retrieveCheap, - removeKey = remove, - hasKey = checkPresent r, + removeKey = remove external, + hasKey = checkPresent external, hasKeyCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -58,195 +64,234 @@ gen r u c gc = do globallyAvailable = False, remotetype = remote } - -store :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool -store k _f _p = undefined - -storeEncrypted :: [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool -storeEncrypted gpgOpts (cipher, enck) k _p = undefined - -retrieve :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -retrieve k _f d _p = undefined + where + externaltype = fromMaybe (error "missing externaltype") $ remoteAnnexExternalType gc + +externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) +externalSetup mu c = do + u <- maybe (liftIO genUUID) return mu + let externaltype = fromMaybe (error "Specify externaltype=") $ + M.lookup "externaltype" c + c' <- encryptionSetup c + + external <- newExternal externaltype + handleRequest external INITREMOTE Nothing $ \resp -> case resp of + INITREMOTE_SUCCESS -> Just noop + INITREMOTE_FAILURE errmsg -> Just $ error errmsg + _ -> Nothing + + gitConfigSpecialRemote u c' "externaltype" externaltype + return (c', u) + +store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store external k _f p = safely $ sendAnnex k rollback $ \f -> + handleRequest external (TRANSFER Upload k f) (Just p) $ \resp -> + case resp of + TRANSFER_SUCCESS Upload k' + | k == k' -> Just $ return True + TRANSFER_FAILURE Upload k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing + where + rollback = void $ remove external k + +storeEncrypted :: External -> [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool +storeEncrypted external gpgOpts (cipher, enck) k _p = safely $ undefined + +retrieve :: External -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +retrieve external k _f d p = safely $ + handleRequest external (TRANSFER Download k d) (Just p) $ \resp -> + case resp of + TRANSFER_SUCCESS Download k' + | k == k' -> Just $ return True + TRANSFER_FAILURE Download k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing retrieveCheap :: Key -> FilePath -> Annex Bool -retrieveCheap _ _ = undefined - -retrieveEncrypted :: (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool -retrieveEncrypted (cipher, enck) _ f _p = undefined - -remove :: Key -> Annex Bool -remove k = undefined - -checkPresent :: Git.Repo -> Key -> Annex (Either String Bool) -checkPresent r k = undefined - --- Messages that git-annex can send. -class Sendable m where - formatMessage :: m -> [String] - --- Messages that git-annex can receive. -class Receivable m where - -- Passed the first word of the message, returns - -- a Parser that can be be fed the rest of the message to generate - -- the value. - parseCommand :: String -> Parser m - -parseMessage :: (Receivable m) => String -> Maybe m -parseMessage s = parseCommand command rest +retrieveCheap _ _ = return False + +retrieveEncrypted :: External -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool +retrieveEncrypted external (cipher, enck) _ f _p = safely $ undefined + +remove :: External -> Key -> Annex Bool +remove external k = safely $ + handleRequest external (REMOVE k) Nothing $ \resp -> + case resp of + REMOVE_SUCCESS k' + | k == k' -> Just $ return True + REMOVE_FAILURE k' errmsg + | k == k' -> Just $ do + warning errmsg + return False + _ -> Nothing + +checkPresent :: External -> Key -> Annex (Either String Bool) +checkPresent external k = either (Left . show) id <$> tryAnnex go where - (command, rest) = splitWord s - --- Messages that can be sent to the external remote to request it do something. -data Request - = PREPARE - | INITREMOTE - | GETCOST - | TRANSFER Direction Key FilePath - | CHECKPRESENT Key - | REMOVE Key - deriving (Show) - -instance Sendable Request where - formatMessage PREPARE = ["PREPARE"] - formatMessage INITREMOTE = ["INITREMOTE"] - formatMessage GETCOST = ["GETCOST"] - formatMessage (TRANSFER direction key file) = - [ "TRANSFER", serialize direction, serialize key, serialize file ] - formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ] - formatMessage (REMOVE key) = [ "REMOVE", serialize key ] - --- Responses the external remote can make to requests. -data Response - = PREPARE_SUCCESS - | TRANSFER_SUCCESS Direction Key - | TRANSFER_FAILURE Direction Key ErrorMsg - | CHECKPRESENT_SUCCESS Key - | CHECKPRESENT_FAILURE Key - | CHECKPRESENT_UNKNOWN Key ErrorMsg - | REMOVE_SUCCESS Key - | REMOVE_FAILURE Key ErrorMsg - | COST Cost - | COST_UNKNOWN - | INITREMOTE_SUCCESS - | INITREMOTE_FAILURE ErrorMsg - deriving (Show) - -instance Receivable Response where - parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS - parseCommand "TRANSFER-SUCCESS" = parse2 TRANSFER_SUCCESS - parseCommand "TRANSFER-FAILURE" = parse3 TRANSFER_FAILURE - parseCommand "CHECKPRESENT-SUCCESS" = parse1 CHECKPRESENT_SUCCESS - parseCommand "CHECKPRESENT-FAILURE" = parse1 CHECKPRESENT_FAILURE - parseCommand "CHECKPRESENT-UNKNOWN" = parse2 CHECKPRESENT_UNKNOWN - parseCommand "REMOVE-SUCCESS" = parse1 REMOVE_SUCCESS - parseCommand "REMOVE-FAILURE" = parse2 REMOVE_FAILURE - parseCommand "COST" = parse1 COST - parseCommand "COST_UNKNOWN" = parse0 COST_UNKNOWN - parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS - parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE - parseCommand _ = parseFail - --- Requests that the external remote can send at any time it's in control. -data RemoteRequest - = VERSION Int - | PROGRESS Direction Key Int - | DIRHASH Key - | SETCONFIG Setting String - | GETCONFIG Setting - | SETSTATE Key String - | GETSTATE Key - deriving (Show) - -instance Receivable RemoteRequest where - parseCommand "VERSION" = parse1 VERSION - parseCommand "PROGRESS" = parse3 PROGRESS - parseCommand "DIRHASH" = parse1 DIRHASH - parseCommand "SETCONFIG" = parse2 SETCONFIG - parseCommand "GETCONFIG" = parse1 GETCONFIG - parseCommand "SETSTATE" = parse2 SETSTATE - parseCommand "GETSTATE" = parse1 GETSTATE - parseCommand _ = parseFail - --- Responses to RemoteRequest. -data RemoteResponse - = VALUE String - deriving (Show) - -instance Sendable RemoteResponse where - formatMessage (VALUE s) = [ "VALUE", serialize s ] - --- Messages that can be sent at any time by either git-annex or the remote. -data AsyncMessages - = ERROR ErrorMsg - deriving (Show) - -instance Sendable AsyncMessages where - formatMessage (ERROR err) = [ "ERROR", serialize err ] - -instance Receivable AsyncMessages where - parseCommand "ERROR" = parse1 ERROR - parseCommand _ = parseFail - --- Data types used for parameters when communicating with the remote. --- All are serializable. -type ErrorMsg = String -type Setting = String - -class Serializable a where - serialize :: a -> String - deserialize :: String -> Maybe a - -instance Serializable Direction where - serialize Upload = "STORE" - serialize Download = "RETRIEVE" - - deserialize "STORE" = Just Upload - deserialize "RETRIEVE" = Just Download - deserialize _ = Nothing - -instance Serializable Key where - serialize = key2file - deserialize = file2key - -instance Serializable [Char] where - serialize = id - deserialize = Just - -instance Serializable Cost where - serialize = show - deserialize = readish - -instance Serializable Int where - serialize = show - deserialize = readish - -{- Parsing the parameters of messages. Using the right parseN ensures - - that the string is split into exactly the requested number of words, - - which allows the last parameter of a message to contain arbitrary - - whitespace, etc, without needing any special quoting. - -} -type Parser a = String -> Maybe a - -parseFail :: Parser a -parseFail _ = Nothing - -parse0 :: a -> Parser a -parse0 mk "" = Just mk -parse0 _ _ = Nothing - -parse1 :: Serializable p1 => (p1 -> a) -> Parser a -parse1 mk p1 = mk <$> deserialize p1 + go = handleRequest external (CHECKPRESENT k) Nothing $ \resp -> + case resp of + CHECKPRESENT_SUCCESS k' + | k' == k -> Just $ return $ Right True + CHECKPRESENT_FAILURE k' + | k' == k -> Just $ return $ Right False + CHECKPRESENT_UNKNOWN k' errmsg + | k' == k -> Just $ return $ Left errmsg + _ -> Nothing + +safely :: Annex Bool -> Annex Bool +safely a = go =<< tryAnnex a + where + go (Right r) = return r + go (Left e) = do + warning $ show e + return False -parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a -parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 +{- Sends a Request to the external remote, and waits for it to generate + - a Response that the responsehandler accepts. + - + - While the external remote is processing the Request, it may send + - any number of RemoteRequests, that are handled here. + - + - Only one request can be made at a time, so locking is used. + - + - May throw exceptions, for example on protocol errors. + -} +handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequest external req mp responsehandler = + withExternalLock external $ \lck -> + handleRequest' lck external req mp responsehandler + +handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequest' lck external req mp responsehandler = do + sendMessage lck external req + loop + where + loop = receiveMessage lck external responsehandler + (\rreq -> Just $ handleRemoteRequest rreq >> loop) + (\msg -> Just $ handleAsyncMessage msg >> loop) + + handleRemoteRequest (PROGRESS bytesprocessed) = + maybe noop (\a -> liftIO $ a bytesprocessed) mp + handleRemoteRequest (DIRHASH k) = + sendMessage lck external (VALUE $ hashDirMixed k) + handleRemoteRequest (SETCONFIG setting value) = error "TODO" + handleRemoteRequest (GETCONFIG setting) = error "TODO" + handleRemoteRequest (SETSTATE k value) = error "TODO" + handleRemoteRequest (GETSTATE k) = error "TODO" + handleRemoteRequest (VERSION _) = + sendMessage lck external (ERROR "too late to send VERSION") + + handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err + +sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex () +sendMessage lck external m = + fromExternal lck external externalSend $ \h -> + liftIO $ hPutStrLn h $ unwords $ formatMessage m + +{- Waits for a message from the external remote, and passes it to the + - apppropriate handler. + - + - If the handler returns Nothing, this is a protocol error.-} +receiveMessage + :: ExternalLock + -> External + -> (Response -> Maybe (Annex a)) + -> (RemoteRequest -> Maybe (Annex a)) + -> (AsyncMessage -> Maybe (Annex a)) + -> Annex a +receiveMessage lck external handleresponse handlerequest handleasync = do + s <- fromExternal lck external externalReceive $ liftIO . hGetLine + case parseMessage s :: Maybe Response of + Just resp -> maybe (protocolError s) id (handleresponse resp) + Nothing -> case parseMessage s :: Maybe RemoteRequest of + Just req -> maybe (protocolError s) id (handlerequest req) + Nothing -> case parseMessage s :: Maybe AsyncMessage of + Just msg -> maybe (protocolError s) id (handleasync msg) + Nothing -> protocolError s where - (p1, p2) = splitWord s + protocolError s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\"" -parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a -parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 +{- Starts up the external remote if it's not yet running, + - and passes a value extracted from its state to an action. + -} +fromExternal :: ExternalLock -> External -> (ExternalState -> v) -> (v -> Annex a) -> Annex a +fromExternal lck external extractor a = + go =<< liftIO (atomically (tryReadTMVar v)) where - (p1, rest) = splitWord s - (p2, p3) = splitWord rest + go (Just st) = run st + go Nothing = do + st <- startExternal $ externalType external + void $ liftIO $ atomically $ swapTMVar v st + + {- Handle initial protocol startup; check the VERSION + - the remote sends, and send it the PREPARE request. -} + receiveMessage lck external + (const Nothing) + (checkVersion lck external) + (const Nothing) + handleRequest' lck external PREPARE Nothing $ \resp -> + case resp of + PREPARE_SUCCESS -> Just $ run st + _ -> Nothing + + run st = a $ extractor st + v = externalState external + +{- Starts an external remote process running, but does not handle checking + - VERSION, etc. -} +startExternal :: ExternalType -> Annex ExternalState +startExternal externaltype = liftIO $ do + (Just hin, Just hout, _, pid) <- createProcess $ + (proc (externalRemoteProgram externaltype) []) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + fileEncoding hin + fileEncoding hout + return $ ExternalState + { externalSend = hin + , externalReceive = hout + , externalPid = pid + } -splitWord :: String -> (String, String) -splitWord = separate isSpace +stopExternal :: External -> Annex () +stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v) + where + stop Nothing = noop + stop (Just st) = do + void $ atomically $ tryTakeTMVar v + hClose $ externalSend st + hClose $ externalReceive st + void $ waitForProcess $ externalPid st + v = externalState external + +externalRemoteProgram :: ExternalType -> String +externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype + +checkVersion :: ExternalLock -> External -> RemoteRequest -> Maybe (Annex ()) +checkVersion lck external (VERSION v) = Just $ + if v `elem` supportedProtocolVersions + then noop + else sendMessage lck external (ERROR "unsupported VERSION") +checkVersion _ _ _ = Nothing + +{- Caches the cost in the git config to avoid needing to start up an + - external special remote every time time just to ask it what its + - cost is. -} +getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost +getCost external r gc = go =<< remoteCost' gc + where + go (Just c) = return c + go Nothing = do + c <- handleRequest external GETCOST Nothing $ \req -> case req of + COST c -> Just $ return c + COST_UNKNOWN -> Just $ return expensiveRemoteCost + _ -> Nothing + setRemoteCost r c + return c diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs new file mode 100644 index 000000000..ed8534a07 --- /dev/null +++ b/Remote/External/Types.hs @@ -0,0 +1,254 @@ +{- External special remote data types. + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Remote.External.Types ( + External(..), + newExternal, + ExternalType, + ExternalLock, + withExternalLock, + ExternalState(..), + parseMessage, + Sendable(..), + Receivable(..), + Request(..), + Response(..), + RemoteRequest(..), + RemoteResponse(..), + AsyncMessage(..), + ErrorMsg, + Setting, + ProtocolVersion, + supportedProtocolVersions, +) where + +import Common.Annex +import Types.Key +import Utility.Metered +import Logs.Transfer +import Config.Cost +import Annex.Exception + +import Data.Char +import Control.Concurrent.STM + +-- If the remote is not yet running, the ExternalState TMVar is empty. +-- The +data External = External + { externalType :: ExternalType + -- Empty until the remote is running. + , externalState :: TMVar ExternalState + -- Empty when a remote is in use. + , externalLock :: TMVar ExternalLock + } + +newExternal :: ExternalType -> Annex External +newExternal externaltype = liftIO $ External + <$> pure externaltype + <*> atomically newEmptyTMVar + <*> atomically (newTMVar ExternalLock) + +type ExternalType = String + +data ExternalState = ExternalState + { externalSend :: Handle + , externalReceive :: Handle + , externalPid :: ProcessHandle + } + +-- Constructor is not exported, and only created by newExternal. +data ExternalLock = ExternalLock + +withExternalLock :: External -> (ExternalLock -> Annex a) -> Annex a +withExternalLock external = bracketIO setup cleanup + where + setup = atomically $ takeTMVar v + cleanup = atomically . putTMVar v + v = externalLock external + +-- Messages that git-annex can send. +class Sendable m where + formatMessage :: m -> [String] + +-- Messages that git-annex can receive. +class Receivable m where + -- Passed the first word of the message, returns + -- a Parser that can be be fed the rest of the message to generate + -- the value. + parseCommand :: String -> Parser m + +parseMessage :: (Receivable m) => String -> Maybe m +parseMessage s = parseCommand command rest + where + (command, rest) = splitWord s + +-- Messages that can be sent to the external remote to request it do something. +data Request + = PREPARE + | INITREMOTE + | GETCOST + | TRANSFER Direction Key FilePath + | CHECKPRESENT Key + | REMOVE Key + deriving (Show) + +instance Sendable Request where + formatMessage PREPARE = ["PREPARE"] + formatMessage INITREMOTE = ["INITREMOTE"] + formatMessage GETCOST = ["GETCOST"] + formatMessage (TRANSFER direction key file) = + [ "TRANSFER", serialize direction, serialize key, serialize file ] + formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ] + formatMessage (REMOVE key) = [ "REMOVE", serialize key ] + +-- Responses the external remote can make to requests. +data Response + = PREPARE_SUCCESS + | TRANSFER_SUCCESS Direction Key + | TRANSFER_FAILURE Direction Key ErrorMsg + | CHECKPRESENT_SUCCESS Key + | CHECKPRESENT_FAILURE Key + | CHECKPRESENT_UNKNOWN Key ErrorMsg + | REMOVE_SUCCESS Key + | REMOVE_FAILURE Key ErrorMsg + | COST Cost + | COST_UNKNOWN + | INITREMOTE_SUCCESS + | INITREMOTE_FAILURE ErrorMsg + | UNKNOWN_REQUEST + deriving (Show) + +instance Receivable Response where + parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS + parseCommand "TRANSFER-SUCCESS" = parse2 TRANSFER_SUCCESS + parseCommand "TRANSFER-FAILURE" = parse3 TRANSFER_FAILURE + parseCommand "CHECKPRESENT-SUCCESS" = parse1 CHECKPRESENT_SUCCESS + parseCommand "CHECKPRESENT-FAILURE" = parse1 CHECKPRESENT_FAILURE + parseCommand "CHECKPRESENT-UNKNOWN" = parse2 CHECKPRESENT_UNKNOWN + parseCommand "REMOVE-SUCCESS" = parse1 REMOVE_SUCCESS + parseCommand "REMOVE-FAILURE" = parse2 REMOVE_FAILURE + parseCommand "COST" = parse1 COST + parseCommand "COST_UNKNOWN" = parse0 COST_UNKNOWN + parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS + parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE + parseCommand "UNKNOWN-REQUEST" = parse0 UNKNOWN_REQUEST + parseCommand _ = parseFail + +-- Requests that the external remote can send at any time it's in control. +data RemoteRequest + = VERSION ProtocolVersion + | PROGRESS BytesProcessed + | DIRHASH Key + | SETCONFIG Setting String + | GETCONFIG Setting + | SETSTATE Key String + | GETSTATE Key + deriving (Show) + +instance Receivable RemoteRequest where + parseCommand "VERSION" = parse1 VERSION + parseCommand "PROGRESS" = parse1 PROGRESS + parseCommand "DIRHASH" = parse1 DIRHASH + parseCommand "SETCONFIG" = parse2 SETCONFIG + parseCommand "GETCONFIG" = parse1 GETCONFIG + parseCommand "SETSTATE" = parse2 SETSTATE + parseCommand "GETSTATE" = parse1 GETSTATE + parseCommand _ = parseFail + +-- Responses to RemoteRequest. +data RemoteResponse + = VALUE String + deriving (Show) + +instance Sendable RemoteResponse where + formatMessage (VALUE s) = [ "VALUE", serialize s ] + +-- Messages that can be sent at any time by either git-annex or the remote. +data AsyncMessage + = ERROR ErrorMsg + deriving (Show) + +instance Sendable AsyncMessage where + formatMessage (ERROR err) = [ "ERROR", serialize err ] + +instance Receivable AsyncMessage where + parseCommand "ERROR" = parse1 ERROR + parseCommand _ = parseFail + +-- Data types used for parameters when communicating with the remote. +-- All are serializable. +type ErrorMsg = String +type Setting = String +type ProtocolVersion = Int + +supportedProtocolVersions :: [ProtocolVersion] +supportedProtocolVersions = [1] + +class Serializable a where + serialize :: a -> String + deserialize :: String -> Maybe a + +instance Serializable Direction where + serialize Upload = "STORE" + serialize Download = "RETRIEVE" + + deserialize "STORE" = Just Upload + deserialize "RETRIEVE" = Just Download + deserialize _ = Nothing + +instance Serializable Key where + serialize = key2file + deserialize = file2key + +instance Serializable [Char] where + serialize = id + deserialize = Just + +instance Serializable ProtocolVersion where + serialize = show + deserialize = readish + +instance Serializable Cost where + serialize = show + deserialize = readish + +instance Serializable BytesProcessed where + serialize (BytesProcessed n) = show n + deserialize = BytesProcessed <$$> readish + +{- Parsing the parameters of messages. Using the right parseN ensures + - that the string is split into exactly the requested number of words, + - which allows the last parameter of a message to contain arbitrary + - whitespace, etc, without needing any special quoting. + -} +type Parser a = String -> Maybe a + +parseFail :: Parser a +parseFail _ = Nothing + +parse0 :: a -> Parser a +parse0 mk "" = Just mk +parse0 _ _ = Nothing + +parse1 :: Serializable p1 => (p1 -> a) -> Parser a +parse1 mk p1 = mk <$> deserialize p1 + +parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a +parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 + where + (p1, p2) = splitWord s + +parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a +parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 + where + (p1, rest) = splitWord s + (p2, p3) = splitWord rest + +splitWord :: String -> (String, String) +splitWord = separate isSpace diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 55ff78514..2d41f51c6 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -63,7 +63,7 @@ gen r u c gc = do remotetype = remote } where - hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc + hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) hookSetup mu c = do diff --git a/Remote/List.hs b/Remote/List.hs index d53b92912..d01d23944 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -35,6 +35,7 @@ import qualified Remote.WebDAV #endif import qualified Remote.Glacier import qualified Remote.Hook +import qualified Remote.External remoteTypes :: [RemoteType] remoteTypes = @@ -52,6 +53,7 @@ remoteTypes = #endif , Remote.Glacier.remote , Remote.Hook.remote + , Remote.External.remote ] {- Builds a list of all available Remotes. diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 7224f43ff..afb40a795 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -113,6 +113,7 @@ data RemoteGitConfig = RemoteGitConfig , remoteAnnexDirectory :: Maybe FilePath , remoteAnnexGCrypt :: Maybe String , remoteAnnexHookType :: Maybe String + , remoteAnnexExternalType :: Maybe String {- A regular git remote's git repository config. -} , remoteGitConfig :: Maybe GitConfig } @@ -137,6 +138,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig , remoteAnnexDirectory = notempty $ getmaybe "directory" , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt" , remoteAnnexHookType = notempty $ getmaybe "hooktype" + , remoteAnnexExternalType = notempty $ getmaybe "externaltype" , remoteGitConfig = Nothing } where diff --git a/Utility/Metered.hs b/Utility/Metered.hs index f33ad443a..7ad9b1215 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -25,7 +25,7 @@ type MeterUpdate = (BytesProcessed -> IO ()) {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer - deriving (Eq, Ord) + deriving (Eq, Ord, Show) class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index a17ce96fc..7dc8182fa 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -1,10 +1,13 @@ -See [[todo/support_for_writing_external_special_remotes]] for motivation. +Communication between git-annex and a program implementing an external +special remote uses this protocol. -This is a design for a protocol to be used to communicate between git-annex -and a program implementing an external special remote. +[[!toc]] + +## starting the program The external special remote program has a name like -`git-annex-remote-$bar`. When `git annex initremote foo type=$bar` is run, +`git-annex-remote-$bar`. When +`git annex initremote foo type=external externaltype=$bar` is run, git-annex finds the appropriate program in PATH. The program is started by git-annex when it needs to access the special @@ -31,7 +34,7 @@ only sends replies to the requests. The special remote is responsible for sending the first message, indicating the version of the protocol it is using. - VERSION 0 + VERSION 1 Once it knows the version, git-annex will send a message telling the special remote to start up. @@ -60,8 +63,8 @@ The special remote can continue sending messages to git-annex during this transfer. It will typically send progress messages, indicating how many bytes have been sent: - PROGRESS STORE somekey 10240 - PROGRESS STORE somekey 20480 + PROGRESS 10240 + PROGRESS 20480 Once the key has been stored, the special remote tells git-annex the result: @@ -79,6 +82,10 @@ remote can send any messages it likes while handling the requests. Once the special remote has finished performing the request, it should send one of the corresponding replies listed in the next section. +More requests may be added over time, so if the special remote sees a +request it does not understand, it should respond with UNKNOWN-REQUEST +and continue running. + * `PREPARE` Tells the special remote it's time to prepare itself to be used. Only run once, at startup, always immediately after the special remote @@ -141,6 +148,8 @@ while it's handling a request. Indicates the INITREMOTE succeeded and the remote is ready to use. * `INITREMOTE-FAILURE ErrorMsg` Indicates that INITREMOTE failed. +* `UNKNOWN-REQUEST` + Indicates that the special remote does not know how to handle a request. ## special remote messages @@ -148,10 +157,10 @@ These messages may be sent by the special remote at any time that it's in control. * `VERSION Int` - Supported protocol version. Current version is 0. Must be sent first + Supported protocol version. Current version is 1. Must be sent first thing at startup, as until it sees this git-annex does not know how to talk with the special remote program! -* `PROGRESS STORE|RETRIEVE Key Int` +* `PROGRESS Int` Indicates the current progress of the transfer (in bytes). May be repeated any number of times during the transfer process. This is highly recommended for STORE. (It is optional but good for RETRIEVE.) @@ -188,75 +197,11 @@ These messages can be sent at any time by either git-annex or the special remote. * `ERROR ErrorMsg` - Generic error. Can be sent at any time if things get messed up. - When possible, use a more specific reply from the list above. - It would be a good idea to send this if git-annex sends a command - you do not support. The program should exit after sending this, as + Generic error. Can be sent at any time if things get too messed up + to continue. When possible, use a more specific reply from the list above. + The special remote program should exit after sending this, as git-annex will not talk to it any further. If the program receives - an ERROR, it can try to recover, or exit with its own ERROR. - -## Simple shell example - -[[!format sh """ -#!/bin/sh -set -e - -echo VERSION 0 - -while read line; do - set -- $line - case "$1" in - INITREMOTE) - # XXX do anything necessary to create resources - # used by the remote. Try to be idempotent. - # Use GETCONFIG to get any needed configuration - # settings, and SETCONFIG to set any persistent - # configuration settings. - echo INITREMOTE-SUCCESS - ;; - GETCOST) - echo COST-UNKNOWN - ;; - PREPARE) - # XXX Use GETCONFIG to get configuration settings, - # and do anything needed to start using the - # special remote here. - echo PREPARE-SUCCESS - ;; - TRANSFER) - key="$3" - file="$4" - case "$2" in - STORE) - # XXX upload file here - # XXX when possible, send PROGRESS - echo TRANSFER-SUCCESS STORE "$key" - ;; - RETRIEVE) - # XXX download file here - echo TRANSFER-SUCCESS RETRIEVE "$key" - ;; - - esac - ;; - CHECKPRESENT) - key="$2" - echo CHECKPRESENT-UNKNOWN "$key" "not implemented" - ;; - REMOVE) - key="$2" - # XXX remove key here - echo REMOVE-SUCCESS "$key" - ;; - *) - echo ERROR "unknown command received: $line" - exit 1 - ;; - esac -done - -# XXX anything that needs to be done at shutdown can be done here -"""]] + an ERROR from git-annex, it can exit with its own ERROR. ## TODO diff --git a/doc/special_remotes.mdwn b/doc/special_remotes.mdwn index 6878a1f88..1a87f1a19 100644 --- a/doc/special_remotes.mdwn +++ b/doc/special_remotes.mdwn @@ -18,14 +18,8 @@ They cannot be used by other git commands though. * [[xmpp]] * [[hook]] -The above special remotes can be used to tie git-annex -into many cloud services. - -There are many use cases for a special remote. You could use it as a backup. You could use it to archive files offline in a drive with encryption enabled so if the drive is stolen your data is not. You could git annex move --to specialremote large files when your local drive is getting full, and then git annex move the files back when free space is again available. You could have one repository copy files to a special remote, and then git annex get them on another repository, to transfer the files between computers that do not communicate directly. - -The git-annex assistant makes it easy to set up rsync remotes using this last scenario, which is referred to as a transfer repository, and arranges to drop files from the transfer repository once they have been transferred to all known clients. - -None of these use cases are particular to particular special remote types. Most special remotes can all be used in these and other ways. It largely doesn't matter for your use what underlying transport the special remote uses. +The above special remotes are built into git-annex, and can be used +to tie git-annex into many cloud services. Here are specific instructions for using git-annex with various services: @@ -45,6 +39,29 @@ for using git-annex with various services: * [[Usenet|forum/nntp__47__usenet special remote]] * [chef-vault](https://github.com/3ofcoins/knife-annex/) +Want to add support for something else? [[Write your own!|external]] + +## Ways to use special remotes + +There are many use cases for a special remote. You could use it as a +backup. You could use it to archive files offline in a drive with +encryption enabled so if the drive is stolen your data is not. You could +git annex move --to specialremote large files when your local drive is +getting full, and then git annex move the files back when free space is +again available. You could have one repository copy files to a special +remote, and then git annex get them on another repository, to transfer the +files between computers that do not communicate directly. + +The git-annex assistant makes it easy to set up rsync remotes using this +last scenario, which is referred to as a transfer repository, and arranges +to drop files from the transfer repository once they have been transferred +to all known clients. + +None of these use cases are particular to particular special remote types. +Most special remotes can all be used in these and other ways. It largely +doesn't matter for your use what underlying transport the special remote +uses. + ## Unused content on special remotes Over time, special remotes can accumulate file content that is no longer diff --git a/doc/special_remotes/external.mdwn b/doc/special_remotes/external.mdwn new file mode 100644 index 000000000..1a62bba64 --- /dev/null +++ b/doc/special_remotes/external.mdwn @@ -0,0 +1,23 @@ +There are three ways to implement a new special remote: + +1. Using the [[hook]] special remote to tell git-annex what commands + to run to store and retrieve data. This is the easiest way, and + is great for prototyping. +2. Writing it in Haskell and adding it to git-annex. +3. Writing a program in any language you like that speaks the + [[external_special_remote_protocol]]. + +The rest of this page concentrates on writing new external special remotes. +It's not hard! + +* All you need is to make a program with a name like `git-annex-remote-$bar`. +* Install it in PATH. +* When the user runs `git annex initremote foo type=external externaltype=$bar`, + it will use your program. +* If you build a new special remote, please add it to the list + of [[special_remotes]]. + +Here's a simple shell script example, which can easily be adapted +to run whatever commands you need. ([[download|example.sh]]) + +[[!inline raw=yes pages="special_remotes/external/example.sh"]] diff --git a/doc/special_remotes/external/example.sh b/doc/special_remotes/external/example.sh new file mode 100755 index 000000000..07dcb2705 --- /dev/null +++ b/doc/special_remotes/external/example.sh @@ -0,0 +1,131 @@ +#!/bin/sh +# git-annex external special remote program +# +# This is basically the same as git-annex's built-in directory special remote. +# +# Install in PATH as git-annex-remote-directorya +# +# Copyright 2013 Joey Hess; licenced under the GNU GPL version 3 or higher. + +set -e + +# This program speaks a line-based protocol on stdin and stdout. +# When running any commands, their stdout should be redirected to stderr +# (or /dev/null) to avoid messing up the protocol. +runcmd () { + "$@" >&2 +} + +# Gets a value from the remote's configuration, and stores it in RET +getconfig () { + echo GETCONFIG "$1" + read resp + set -- $resp + case "$1" in + VALUE) + RET="$2" + ;; + *) + RET="" + ;; + esac +} + +# Sets LOC to the location to use to store a key. +mylocation () { + echo HASHDIR "$1" + read resp + set -- $resp + case "$1" in + VALUE) + LOC="$hashdir/$1" + ;; + *) + LOC= + ;; + esac +} + +echo VERSION 1 + +while read line; do + set -- $line + case "$1" in + INITREMOTE) + # XXX do anything necessary to create resources + # used by the remote. Try to be idempotent. + # Use GETCONFIG to get any needed configuration + # settings, and SETCONFIG to set any persistent + # configuration settings. + getconfig directory + mydirectory="$RET" + if [ -z "$mydirectory" ]; then + echo INITREMOTE-FAILURE "You need to set directory=" + else + mkdir -p "$mydirectory" + echo INITREMOTE-SUCCESS + fi + ;; + GETCOST) + echo COST-UNKNOWN + ;; + PREPARE) + # XXX Use GETCONFIG to get configuration settings, + # and do anything needed to get ready for using the + # special remote here. + getconfig directory + mydirectory="$RET" + ;; + TRANSFER) + key="$3" + file="$4" + case "$2" in + STORE) + # XXX upload file here + # XXX when possible, send PROGRESS + calclocation "$key" + mkdir -p "$(dirname "$LOC")" + runcmd cp -v "$file" "$LOC" + echo TRANSFER-SUCCESS STORE "$key" + ;; + RETRIEVE) + # XXX download file here + calclocation "$key" + runcmd cp -v "$LOC" "$file" + echo TRANSFER-SUCCESS RETRIEVE "$key" + ;; + esac + ;; + CHECKPRESENT) + key="$2" + calclocation "$key" + if [ -e "$LOC" ]; then + echo CHECKPRESENT-SUCCESS "$key" + else + if [ -d "$mydirectory" ]; then + echo CHECKPRESENT-FAILURE "$key" + else + # If the directory does not exist, + # the remote is not available. + # (A network remote would similarly + # fail with CHECKPRESENT-UNKNOWN + # if it couldn't be contacted). + echo CHECKPRESENT-UNKNOWN "$key" "this remote is not currently available" + fi + fi + ;; + REMOVE) + key="$2" + calclocation "$key" + # Note that it's not a failure to remove a + # key that is not present, so -f is used. + runcmd rm -f "$LOC" + echo REMOVE-SUCCESS "$key" + ;; + *) + echo UNKNOWN-REQUEST + ;; + esac +done + +# XXX anything that needs to be done at shutdown can be done here diff --git a/doc/special_remotes/hook.mdwn b/doc/special_remotes/hook.mdwn index eaea940a7..8cf31ed02 100644 --- a/doc/special_remotes/hook.mdwn +++ b/doc/special_remotes/hook.mdwn @@ -1,9 +1,12 @@ This special remote type lets you store content in a remote of your own -devising. +devising, configured via some simple hooks. It's not recommended to use this remote type when another like [[rsync]] or [[directory]] will do. If your hooks are not carefully written, data -could be lost. +could be lost. + +If you're building a special remote for others to use, +instead consider building an [[external_special_remote|external]]. ## example @@ -68,6 +71,9 @@ The settings to use in git config for the hook commands are as follows: ## combined hook program +This interface is deprecated -- it's better, and not much harder, +to write an [[external_special_remote|external]]! + Rather than setting all of the above hooks, you can write a single program that handles everything, and set a single hook to make it be used. @@ -75,7 +81,7 @@ program that handles everything, and set a single hook to make it be used. # git annex initremote mydemorepo type=hook hooktype=demo encryption=none The program just needs to look at the `ANNEX_ACTION` environment variable -to see what it's being asked to do For example: +to see what it's being asked to do. For example: [[!format sh """ #!/bin/sh diff --git a/doc/todo/support_for_writing_external_special_remotes.mdwn b/doc/todo/support_for_writing_external_special_remotes.mdwn index 2d7cd9d15..1732f77ea 100644 --- a/doc/todo/support_for_writing_external_special_remotes.mdwn +++ b/doc/todo/support_for_writing_external_special_remotes.mdwn @@ -23,3 +23,5 @@ should look for `git-annex-remote-$bar` in PATH if that's not a built-in special remote name. --[[Joey]] + +[[done]] diff --git a/standalone/android/buildchroot-inchroot b/standalone/android/buildchroot-inchroot index 70deea0ab..a5fa2ce85 100755 --- a/standalone/android/buildchroot-inchroot +++ b/standalone/android/buildchroot-inchroot @@ -12,6 +12,7 @@ mount -t proc proc /proc echo "deb-src http://ftp.us.debian.org/debian stable main" >> /etc/apt/sources.list apt-get update apt-get -y install build-essential ghc git libncurses5-dev cabal-install +apt-get -y install happy alex apt-get -y install llvm-3.0 # not 3.1; buggy on arm. 3.2 is ok too apt-get -y install ca-certificates curl file m4 autoconf zlib1g-dev apt-get -y install libgnutls-dev libxml2-dev libgsasl7-dev pkg-config c2hs diff --git a/standalone/android/haskell-patches/HTTP_4000.2.8-0001-build-with-base-4.8.patch b/standalone/android/haskell-patches/HTTP_4000.2.8-0001-build-with-base-4.8.patch deleted file mode 100644 index dfcdc387f..000000000 --- a/standalone/android/haskell-patches/HTTP_4000.2.8-0001-build-with-base-4.8.patch +++ /dev/null @@ -1,25 +0,0 @@ -From 5c57c4ae7dac0c1aa940005f5ea55fdcd4fcd1f5 Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sat, 21 Sep 2013 22:46:42 +0000 -Subject: [PATCH] fix build with new base - ---- - HTTP.cabal | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/HTTP.cabal b/HTTP.cabal -index 76cb5d6..bb38f24 100644 ---- a/HTTP.cabal -+++ b/HTTP.cabal -@@ -85,7 +85,7 @@ Library - Network.HTTP.Utils - Paths_HTTP - GHC-options: -fwarn-missing-signatures -Wall -- Build-depends: base >= 2 && < 4.7, network < 2.5, parsec -+ Build-depends: base >= 2 && < 4.9, network < 2.5, parsec - Extensions: FlexibleInstances - if flag(old-base) - Build-depends: base < 3 --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/MonadCatchIO-transformers_hack-to-get-to-build-with-new-ghc.patch b/standalone/android/haskell-patches/MonadCatchIO-transformers_hack-to-get-to-build-with-new-ghc.patch deleted file mode 100644 index 9881d35d6..000000000 --- a/standalone/android/haskell-patches/MonadCatchIO-transformers_hack-to-get-to-build-with-new-ghc.patch +++ /dev/null @@ -1,56 +0,0 @@ -From 083c9d135ec68316db173235994c63603ad76444 Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sat, 21 Sep 2013 23:01:35 +0000 -Subject: [PATCH] hack to get to build with new ghc - -Copied the old implemenations of block and unblock from old Control.Exception -since these deprecated functions have now been removed. ---- - MonadCatchIO-transformers.cabal | 2 +- - src/Control/Monad/CatchIO.hs | 13 +++++++++++-- - 2 files changed, 12 insertions(+), 3 deletions(-) - -diff --git a/MonadCatchIO-transformers.cabal b/MonadCatchIO-transformers.cabal -index fe6674d..b9f559f 100644 ---- a/MonadCatchIO-transformers.cabal -+++ b/MonadCatchIO-transformers.cabal -@@ -26,4 +26,4 @@ Library - Exposed-Modules: - Control.Monad.CatchIO - Hs-Source-Dirs: src -- Ghc-options: -Wall -+ Ghc-options: -Wall -fglasgow-exts -diff --git a/src/Control/Monad/CatchIO.hs b/src/Control/Monad/CatchIO.hs -index 62afb83..853996b 100644 ---- a/src/Control/Monad/CatchIO.hs -+++ b/src/Control/Monad/CatchIO.hs -@@ -19,6 +19,9 @@ where - import Prelude hiding ( catch ) - import Control.Applicative ((<$>)) - import qualified Control.Exception.Extensible as E -+import qualified Control.Exception.Base as E -+import GHC.Base (maskAsyncExceptions#) -+import GHC.IO (unsafeUnmask, IO(..)) - - import Control.Monad.IO.Class (MonadIO,liftIO) - -@@ -51,8 +54,14 @@ class MonadIO m => MonadCatchIO m where - - instance MonadCatchIO IO where - catch = E.catch -- block = E.block -- unblock = E.unblock -+ block = oldblock -+ unblock = oldunblock -+ -+oldblock :: IO a -> IO a -+oldblock (IO io) = IO $ maskAsyncExceptions# io -+ -+oldunblock :: IO a -> IO a -+oldunblock = unsafeUnmask - - -- | Warning: this instance is somewhat contentious. - -- --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/network_2.4.1.0_0001-android-port-fixes.patch b/standalone/android/haskell-patches/network_2.4.1.0_0001-android-port-fixes.patch index d7d0608d2..66c0de544 100644 --- a/standalone/android/haskell-patches/network_2.4.1.0_0001-android-port-fixes.patch +++ b/standalone/android/haskell-patches/network_2.4.1.0_0001-android-port-fixes.patch @@ -1,6 +1,6 @@ -From 9750532bd6200353fe09dda65ee6fb59702c4ac1 Mon Sep 17 00:00:00 2001 -From: Joey Hess <joey@kitenet.net> -Date: Thu, 28 Feb 2013 23:32:15 -0400 +From 3b478080f72240e0eb4b03b7eae52a0f5385bfef Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Thu, 26 Dec 2013 12:35:39 -0400 Subject: [PATCH] android port fixes Build note: Ensure a hsc2hs in PATH is modified to pass -x to the real @@ -14,14 +14,13 @@ one, to enable cross-compiling. config.guess | 562 ++++++++++++++++++++++------------------- config.sub | 384 ++++++++++++++++++++-------- configure | 1 + - include/HsNetworkConfig.h | 8 +- - 9 files changed, 612 insertions(+), 387 deletions(-) + 8 files changed, 608 insertions(+), 383 deletions(-) diff --git a/Network/Socket.hsc b/Network/Socket.hsc -index 259e843..e6c0feb 100644 +index 6d304bb..9b34776 100644 --- a/Network/Socket.hsc +++ b/Network/Socket.hsc -@@ -38,7 +38,7 @@ module Network.Socket +@@ -35,7 +35,7 @@ module Network.Socket , SockAddr(..) , SocketStatus(..) , HostAddress @@ -30,7 +29,7 @@ index 259e843..e6c0feb 100644 , HostAddress6 , FlowInfo , ScopeID -@@ -55,7 +55,7 @@ module Network.Socket +@@ -52,7 +52,7 @@ module Network.Socket , HostName , ServiceName @@ -48,7 +47,7 @@ index 259e843..e6c0feb 100644 , iN6ADDR_ANY #endif , sOMAXCONN -@@ -330,16 +330,6 @@ socket family stype protocol = do +@@ -326,16 +326,6 @@ socket family stype protocol = do setNonBlockIfNeeded fd socket_status <- newMVar NotConnected let sock = MkSocket fd family stype protocol socket_status @@ -65,7 +64,7 @@ index 259e843..e6c0feb 100644 return sock -- | Build a pair of connected socket objects using the given address -@@ -1043,9 +1033,9 @@ aNY_PORT = 0 +@@ -1059,9 +1049,9 @@ aNY_PORT = 0 iNADDR_ANY :: HostAddress iNADDR_ANY = htonl (#const INADDR_ANY) @@ -77,7 +76,7 @@ index 259e843..e6c0feb 100644 -- | The IPv6 wild card address. iN6ADDR_ANY :: HostAddress6 -@@ -1219,7 +1209,7 @@ unpackBits ((k,v):xs) r +@@ -1239,7 +1229,7 @@ unpackBits ((k,v):xs) r ----------------------------------------------------------------------------- -- Address and service lookups @@ -87,10 +86,10 @@ index 259e843..e6c0feb 100644 -- | Flags that control the querying behaviour of 'getAddrInfo'. data AddrInfoFlag diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc -index bec2eb9..cb8ed8c 100644 +index e21ad1b..c2dd70a 100644 --- a/Network/Socket/ByteString.hsc +++ b/Network/Socket/ByteString.hsc -@@ -201,7 +201,7 @@ sendMany sock@(MkSocket fd _ _ _ _) cs = do +@@ -197,7 +197,7 @@ sendMany sock@(MkSocket fd _ _ _ _) cs = do liftM fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) -> throwSocketErrorWaitWrite sock "writev" $ c_writev (fromIntegral fd) iovsPtr @@ -100,7 +99,7 @@ index bec2eb9..cb8ed8c 100644 sendMany sock = sendAll sock . B.concat #endif diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc -index 96fe9c6..df5ce64 100644 +index 83333f7..0dd6a7d 100644 --- a/Network/Socket/Internal.hsc +++ b/Network/Socket/Internal.hsc @@ -24,7 +24,7 @@ module Network.Socket.Internal @@ -113,10 +112,10 @@ index 96fe9c6..df5ce64 100644 , FlowInfo , ScopeID diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc -index 7ad24f1..dad1d1d 100644 +index 48a43bb..1c5994f 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc -@@ -705,8 +705,8 @@ intToPortNumber v = PortNum (htons (fromIntegral v)) +@@ -711,8 +711,8 @@ intToPortNumber v = PortNum (htons (fromIntegral v)) portNumberToInt :: PortNumber -> Int portNumberToInt (PortNum po) = fromIntegral (ntohs po) @@ -1911,50 +1910,15 @@ index ad9f395..802a224 100644 ;; -beos*) diff --git a/configure b/configure -index a9e9814..7fd6318 100755 +index 1e352d9..e375246 100755 --- a/configure +++ b/configure @@ -1,4 +1,5 @@ #! /bin/sh +set -- --host=arm-linux-androideabi # Guess values for system-dependent variables and create Makefiles. - # Generated by GNU Autoconf 2.69 for Haskell network package 2.3.0.14. + # Generated by GNU Autoconf 2.68 for Haskell network package 2.3.0.14. # -diff --git a/include/HsNetworkConfig.h b/include/HsNetworkConfig.h -index c6e704d..4edc892 100644 ---- a/include/HsNetworkConfig.h -+++ b/include/HsNetworkConfig.h -@@ -8,7 +8,7 @@ - #define HAVE_ARPA_INET_H 1 - - /* Define to 1 if you have a BSDish sendfile(2) implementation. */ --#define HAVE_BSD_SENDFILE 1 -+/* #undef HAVE_BSD_SENDFILE */ - - /* Define to 1 if you have the declaration of `AI_ADDRCONFIG', and to 0 if you - don't. */ -@@ -55,7 +55,7 @@ - #define HAVE_LIMITS_H 1 - - /* Define to 1 if you have a Linux sendfile(2) implementation. */ --/* #undef HAVE_LINUX_SENDFILE */ -+#define HAVE_LINUX_SENDFILE 1 - - /* Define to 1 if you have the <memory.h> header file. */ - #define HAVE_MEMORY_H 1 -@@ -91,10 +91,10 @@ - #define HAVE_STRUCT_MSGHDR_MSG_CONTROL 1 - - /* Define to 1 if `sa_len' is a member of `struct sockaddr'. */ --#define HAVE_STRUCT_SOCKADDR_SA_LEN 1 -+/* #undef HAVE_STRUCT_SOCKADDR_SA_LEN */ - - /* Define to 1 if you have both SO_PEERCRED and struct ucred. */ --/* #undef HAVE_STRUCT_UCRED */ -+#define HAVE_STRUCT_UCRED 1 - - /* Define to 1 if you have the `symlink' function. */ - #define HAVE_SYMLINK 1 -- 1.7.10.4 diff --git a/standalone/android/haskell-patches/process_fix-build-with-new-ghc.patch b/standalone/android/haskell-patches/process_fix-build-with-new-ghc.patch deleted file mode 100644 index a790a316d..000000000 --- a/standalone/android/haskell-patches/process_fix-build-with-new-ghc.patch +++ /dev/null @@ -1,24 +0,0 @@ -From 0b0d4250cfce44b1a03b50458b4122370ab349ce Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sat, 21 Sep 2013 21:50:51 +0000 -Subject: [PATCH] fix build with new ghc - ---- - System/Process/Internals.hs | 1 + - 1 file changed, 1 insertion(+) - -diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs -index a73c6fc..6676a72 100644 ---- a/System/Process/Internals.hs -+++ b/System/Process/Internals.hs -@@ -61,6 +61,7 @@ import Control.Concurrent - import Control.Exception - import Foreign.C - import Foreign -+import System.IO.Unsafe - - # ifdef __GLASGOW_HASKELL__ - --- -1.7.10.4 - diff --git a/standalone/android/install-haskell-packages b/standalone/android/install-haskell-packages index 333a88260..9b8baf2f6 100755 --- a/standalone/android/install-haskell-packages +++ b/standalone/android/install-haskell-packages @@ -66,14 +66,11 @@ install_pkgs () { patched unix-time patched lifted-base patched zlib - patched process patched MissingH patched bloomfilter patched SafeSemaphore patched distributive patched comonad - patched HTTP - patched MonadCatchIO-transformers patched iproute patched primitive patched socks diff --git a/standalone/no-th/haskell-patches/persistent-template_stub-out.patch b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch index 6b7b62bd4..29002eb32 100644 --- a/standalone/no-th/haskell-patches/persistent-template_stub-out.patch +++ b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch @@ -1,6 +1,6 @@ -From 0b9df0de3aa45918a2a9226a2da6be4680276419 Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sun, 22 Sep 2013 03:31:55 +0000 +From 4b958f97bffdeedc0c946d5fdc9749d2cc566fcc Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Thu, 26 Dec 2013 15:54:37 -0400 Subject: [PATCH] stub out --- @@ -8,15 +8,15 @@ Subject: [PATCH] stub out 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-template.cabal b/persistent-template.cabal -index 8216ce7..f23234b 100644 +index c4aee68..7905278 100644 --- a/persistent-template.cabal +++ b/persistent-template.cabal -@@ -23,7 +23,7 @@ library - , containers +@@ -24,7 +24,7 @@ library , aeson , monad-logger + , unordered-containers - exposed-modules: Database.Persist.TH -+ exposed-modules: ++ exposed-modules: ghc-options: -Wall if impl(ghc >= 7.4) cpp-options: -DGHC_7_4 |