aboutsummaryrefslogtreecommitdiff
path: root/Assistant/Types
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Types')
-rw-r--r--Assistant/Types/Buddies.hs80
-rw-r--r--Assistant/Types/DaemonStatus.hs8
-rw-r--r--Assistant/Types/NetMessager.hs155
3 files changed, 0 insertions, 243 deletions
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
deleted file mode 100644
index 432440d2e..000000000
--- a/Assistant/Types/Buddies.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{- git-annex assistant buddies
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE CPP #-}
-
-module Assistant.Types.Buddies where
-
-import Annex.Common
-
-import qualified Data.Map as M
-import Control.Concurrent.STM
-import Utility.NotificationBroadcaster
-import Data.Text as T
-
-{- For simplicity, dummy types are defined even when XMPP is disabled. -}
-#ifdef WITH_XMPP
-import Network.Protocol.XMPP
-import Data.Set as S
-import Data.Ord
-
-newtype Client = Client JID
- deriving (Eq, Show)
-
-instance Ord Client where
- compare = comparing show
-
-data Buddy = Buddy
- { buddyPresent :: S.Set Client
- , buddyAway :: S.Set Client
- , buddyAssistants :: S.Set Client
- , buddyPairing :: Bool
- }
-#else
-data Buddy = Buddy
-#endif
- deriving (Eq, Show)
-
-data BuddyKey = BuddyKey T.Text
- deriving (Eq, Ord, Show, Read)
-
-data PairKey = PairKey UUID T.Text
- deriving (Eq, Ord, Show, Read)
-
-type Buddies = M.Map BuddyKey Buddy
-
-{- A list of buddies, and a way to notify when it changes. -}
-type BuddyList = (TMVar Buddies, NotificationBroadcaster)
-
-noBuddies :: Buddies
-noBuddies = M.empty
-
-newBuddyList :: IO BuddyList
-newBuddyList = (,)
- <$> atomically (newTMVar noBuddies)
- <*> newNotificationBroadcaster
-
-getBuddyList :: BuddyList -> IO [Buddy]
-getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
-
-getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
-getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
-
-getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
-getBuddyBroadcaster (_, h) = h
-
-{- Applies a function to modify the buddy list, and if it's changed,
- - sends notifications to any listeners. -}
-updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
-updateBuddyList a (v, caster) = do
- changed <- atomically $ do
- buds <- takeTMVar v
- let buds' = a buds
- putTMVar v buds'
- return $ buds /= buds'
- when changed $
- sendNotification caster
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index 0e52d3477..08e98d98e 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -12,7 +12,6 @@ import Assistant.Pairing
import Utility.NotificationBroadcaster
import Types.Transfer
import Assistant.Types.ThreadName
-import Assistant.Types.NetMessager
import Assistant.Types.Alert
import Utility.Url
@@ -54,8 +53,6 @@ data DaemonStatus = DaemonStatus
, syncingToCloudRemote :: Bool
-- Set of uuids of remotes that are currently connected.
, currentlyConnectedRemotes :: S.Set UUID
- -- List of uuids of remotes that we may have gotten out of sync with.
- , desynced :: S.Set UUID
-- Pairing request that is in progress.
, pairingInProgress :: Maybe PairingInProgress
-- Broadcasts notifications about all changes to the DaemonStatus.
@@ -77,9 +74,6 @@ data DaemonStatus = DaemonStatus
, globalRedirUrl :: Maybe URLString
-- Actions to run after a Key is transferred.
, transferHook :: M.Map Key (Transfer -> IO ())
- -- When the XMPP client is connected, this will contain the XMPP
- -- address.
- , xmppClientID :: Maybe ClientID
-- MVars to signal when a remote gets connected.
, connectRemoteNotifiers :: M.Map UUID [MVar ()]
}
@@ -105,7 +99,6 @@ newDaemonStatus = DaemonStatus
<*> pure []
<*> pure False
<*> pure S.empty
- <*> pure S.empty
<*> pure Nothing
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
@@ -117,5 +110,4 @@ newDaemonStatus = DaemonStatus
<*> newNotificationBroadcaster
<*> pure Nothing
<*> pure M.empty
- <*> pure Nothing
<*> pure M.empty
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
deleted file mode 100644
index da6682233..000000000
--- a/Assistant/Types/NetMessager.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{- git-annex assistant out of band network messager types
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Types.NetMessager where
-
-import Annex.Common
-import Assistant.Pairing
-import Git.Types
-
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Set as S
-import qualified Data.Map as M
-import qualified Data.DList as D
-import Control.Concurrent.STM
-import Control.Concurrent.MSampleVar
-import Data.ByteString (ByteString)
-import Data.Text (Text)
-
-{- Messages that can be sent out of band by a network messager. -}
-data NetMessage
- -- indicate that pushes have been made to the repos with these uuids
- = NotifyPush [UUID]
- -- requests other clients to inform us of their presence
- | QueryPresence
- -- notification about a stage in the pairing process,
- -- involving a client, and a UUID.
- | PairingNotification PairStage ClientID UUID
- -- used for git push over the network messager
- | Pushing ClientID PushStage
- deriving (Eq, Ord, Show)
-
-{- Something used to identify the client, or clients to send the message to. -}
-type ClientID = Text
-
-data PushStage
- -- indicates that we have data to push over the out of band network
- = CanPush UUID [Sha]
- -- request that a git push be sent over the out of band network
- | PushRequest UUID
- -- indicates that a push is starting
- | StartingPush UUID
- -- a chunk of output of git receive-pack
- | ReceivePackOutput SequenceNum ByteString
- -- a chuck of output of git send-pack
- | SendPackOutput SequenceNum ByteString
- -- sent when git receive-pack exits, with its exit code
- | ReceivePackDone ExitCode
- deriving (Eq, Ord, Show)
-
-{- A sequence number. Incremented by one per packet in a sequence,
- - starting with 1 for the first packet. 0 means sequence numbers are
- - not being used. -}
-type SequenceNum = Int
-
-{- NetMessages that are important (and small), and should be stored to be
- - resent when new clients are seen. -}
-isImportantNetMessage :: NetMessage -> Maybe ClientID
-isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
-isImportantNetMessage (Pushing c (PushRequest _)) = Just c
-isImportantNetMessage _ = Nothing
-
-{- Checks if two important NetMessages are equivilant.
- - That is to say, assuming they were sent to the same client,
- - would it do the same thing for one as for the other? -}
-equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool
-equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True
-equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True
-equivilantImportantNetMessages _ _ = False
-
-readdressNetMessage :: NetMessage -> ClientID -> NetMessage
-readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid
-readdressNetMessage (Pushing _ stage) c = Pushing c stage
-readdressNetMessage m _ = m
-
-{- Convert a NetMessage to something that can be logged. -}
-logNetMessage :: NetMessage -> String
-logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
- case stage of
- ReceivePackOutput n _ -> ReceivePackOutput n elided
- SendPackOutput n _ -> SendPackOutput n elided
- s -> s
- where
- elided = T.encodeUtf8 $ T.pack "<elided>"
-logNetMessage (PairingNotification stage c uuid) =
- show $ PairingNotification stage (logClientID c) uuid
-logNetMessage m = show m
-
-logClientID :: ClientID -> ClientID
-logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
-
-{- Things that initiate either side of a push, but do not actually send data. -}
-isPushInitiation :: PushStage -> Bool
-isPushInitiation (PushRequest _) = True
-isPushInitiation (StartingPush _) = True
-isPushInitiation _ = False
-
-isPushNotice :: PushStage -> Bool
-isPushNotice (CanPush _ _) = True
-isPushNotice _ = False
-
-data PushSide = SendPack | ReceivePack
- deriving (Eq, Ord, Show)
-
-pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide (CanPush _ _) = ReceivePack
-pushDestinationSide (PushRequest _) = SendPack
-pushDestinationSide (StartingPush _) = ReceivePack
-pushDestinationSide (ReceivePackOutput _ _) = SendPack
-pushDestinationSide (SendPackOutput _ _) = ReceivePack
-pushDestinationSide (ReceivePackDone _) = SendPack
-
-type SideMap a = PushSide -> a
-
-mkSideMap :: STM a -> IO (SideMap a)
-mkSideMap gen = do
- (sp, rp) <- atomically $ (,) <$> gen <*> gen
- return $ lookupside sp rp
- where
- lookupside sp _ SendPack = sp
- lookupside _ rp ReceivePack = rp
-
-getSide :: PushSide -> SideMap a -> a
-getSide side m = m side
-
-type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))
-
-data NetMessager = NetMessager
- -- outgoing messages
- { netMessages :: TChan NetMessage
- -- important messages for each client
- , importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
- -- important messages that are believed to have been sent to a client
- , sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
- -- write to this to restart the net messager
- , netMessagerRestart :: MSampleVar ()
- -- queue of incoming messages that request the initiation of pushes
- , netMessagerPushInitiations :: SideMap (TMVar [NetMessage])
- -- incoming messages containing data for a running
- -- (or not yet started) push
- , netMessagerInboxes :: SideMap Inboxes
- }
-
-newNetMessager :: IO NetMessager
-newNetMessager = NetMessager
- <$> atomically newTChan
- <*> atomically (newTMVar M.empty)
- <*> atomically (newTMVar M.empty)
- <*> newEmptySV
- <*> mkSideMap newEmptyTMVar
- <*> mkSideMap (newTVar M.empty)