more nice refactoring
This commit is contained in:
Joey Hess
parent
7ab993ffc9
commit
0cf4c3ba9c
2 changed files with 75 additions and 92 deletions
|
|
@ -134,19 +134,7 @@ decodeStanza selfjid s@(ReceivedMessage m)
|
|||
| messageFrom m == Nothing = [Ignorable s]
|
||||
| messageFrom m == Just selfjid = [Ignorable s]
|
||||
| messageType m == MessageError = [ProtocolError s]
|
||||
| otherwise = [fromMaybe (Unknown s) $ decode =<< gitAnnexTagInfo m]
|
||||
where
|
||||
decode i = GotNetMessage <$>
|
||||
((\d -> d m i) =<< M.lookup (tagAttr i) decoders)
|
||||
decoders = M.fromList
|
||||
[ (pairAttr, decodePairingNotification)
|
||||
, (canPushAttr, decodeCanPush)
|
||||
, (pushRequestAttr, decodePushRequest)
|
||||
, (startingPushAttr, decodeStartingPush)
|
||||
, (receivePackAttr, decodeReceivePackOutput)
|
||||
, (sendPackAttr, decodeSendPackOutput)
|
||||
, (receivePackDoneAttr, decodeReceivePackDone)
|
||||
]
|
||||
| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
|
||||
decodeStanza _ s = [Unknown s]
|
||||
|
||||
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
|
||||
|
|
@ -158,12 +146,8 @@ relayNetMessage selfjid = convert =<< waitNetMessage
|
|||
convert (PairingNotification stage c u) = withclient c $ \tojid -> do
|
||||
changeBuddyPairing tojid True
|
||||
return $ putStanza $ pairingNotification stage u tojid selfjid
|
||||
convert (Pushing c CanPush) = sendclient c canPush
|
||||
convert (Pushing c PushRequest) = sendclient c pushRequest
|
||||
convert (Pushing c StartingPush) = sendclient c startingPush
|
||||
convert (Pushing c (ReceivePackOutput b)) = sendclient c $ receivePackOutput b
|
||||
convert (Pushing c (SendPackOutput b)) = sendclient c $ sendPackOutput b
|
||||
convert (Pushing c (ReceivePackDone code)) = sendclient c $ receivePackDone code
|
||||
convert (Pushing c pushstage) = sendclient c $
|
||||
gitAnnexMessage $ encodePushStage pushstage
|
||||
|
||||
sendclient c construct = withclient c $ \tojid ->
|
||||
return $ putStanza $ construct tojid selfjid
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ import Assistant.Pairing
|
|||
import Network.Protocol.XMPP hiding (Node)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.XML.Types
|
||||
|
|
@ -91,40 +92,31 @@ gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
|
|||
pushNotification :: [UUID] -> Presence
|
||||
pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
|
||||
|
||||
pushAttr :: Name
|
||||
pushAttr = "push"
|
||||
|
||||
uuidSep :: Text
|
||||
uuidSep = ","
|
||||
|
||||
encodePushNotification :: [UUID] -> Text
|
||||
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
|
||||
|
||||
decodePushNotification :: Text -> [UUID]
|
||||
decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
|
||||
|
||||
uuidSep :: Text
|
||||
uuidSep = ","
|
||||
|
||||
{- A request for other git-annex clients to send presence. -}
|
||||
presenceQuery :: Presence
|
||||
presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
|
||||
|
||||
queryAttr :: Name
|
||||
queryAttr = "query"
|
||||
|
||||
{- A notification about a stage of pairing. -}
|
||||
pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
|
||||
pairingNotification pairstage u = gitAnnexMessage $
|
||||
gitAnnexTag pairAttr $ encodePairingNotification pairstage u
|
||||
|
||||
pairAttr :: Name
|
||||
pairAttr = "pair"
|
||||
|
||||
encodePairingNotification :: PairStage -> UUID -> Text
|
||||
encodePairingNotification pairstage u = T.unwords $ map T.pack
|
||||
[ show pairstage
|
||||
, fromUUID u
|
||||
]
|
||||
|
||||
decodePairingNotification :: Message -> GitAnnexTagInfo -> Maybe NetMessage
|
||||
decodePairingNotification :: Decoder
|
||||
decodePairingNotification m = parse . words . T.unpack . tagValue
|
||||
where
|
||||
parse [stage, u] = PairingNotification
|
||||
|
|
@ -133,70 +125,50 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
|
|||
<*> pure (toUUID u)
|
||||
parse _ = Nothing
|
||||
|
||||
canPush :: JID -> JID -> Message
|
||||
canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
|
||||
|
||||
decodeCanPush :: PushDecoder
|
||||
decodeCanPush = mkPushDecoder $ const $ Just CanPush
|
||||
|
||||
canPushAttr :: Name
|
||||
canPushAttr = "canpush"
|
||||
|
||||
pushRequest :: JID -> JID -> Message
|
||||
pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
|
||||
|
||||
decodePushRequest :: PushDecoder
|
||||
decodePushRequest = mkPushDecoder $ const $ Just PushRequest
|
||||
|
||||
pushRequestAttr :: Name
|
||||
pushRequestAttr = "pushrequest"
|
||||
|
||||
startingPush :: JID -> JID -> Message
|
||||
startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
|
||||
|
||||
startingPushAttr :: Name
|
||||
startingPushAttr = "startingpush"
|
||||
|
||||
decodeStartingPush :: PushDecoder
|
||||
decodeStartingPush = mkPushDecoder $ const $ Just StartingPush
|
||||
|
||||
receivePackOutput :: ByteString -> JID -> JID -> Message
|
||||
receivePackOutput = gitAnnexMessage .
|
||||
gitAnnexTagContent receivePackAttr T.empty . encodeTagContent
|
||||
|
||||
receivePackAttr :: Name
|
||||
receivePackAttr = "rp"
|
||||
|
||||
decodeReceivePackOutput :: PushDecoder
|
||||
decodeReceivePackOutput = mkPushDecoder $
|
||||
fmap ReceivePackOutput . decodeTagContent . tagElement
|
||||
|
||||
sendPackOutput :: ByteString -> JID -> JID -> Message
|
||||
sendPackOutput = gitAnnexMessage .
|
||||
gitAnnexTagContent sendPackAttr T.empty . encodeTagContent
|
||||
|
||||
sendPackAttr :: Name
|
||||
sendPackAttr = "sp"
|
||||
|
||||
decodeSendPackOutput :: PushDecoder
|
||||
decodeSendPackOutput = mkPushDecoder $
|
||||
fmap SendPackOutput . decodeTagContent . tagElement
|
||||
|
||||
receivePackDone :: ExitCode -> JID -> JID -> Message
|
||||
receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . show . toi
|
||||
encodePushStage :: PushStage -> Element
|
||||
encodePushStage CanPush = gitAnnexTag canPushAttr T.empty
|
||||
encodePushStage PushRequest = gitAnnexTag pushRequestAttr T.empty
|
||||
encodePushStage StartingPush = gitAnnexTag startingPushAttr T.empty
|
||||
encodePushStage (ReceivePackOutput b) =
|
||||
gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
|
||||
encodePushStage (SendPackOutput b) =
|
||||
gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
|
||||
encodePushStage (ReceivePackDone code) =
|
||||
gitAnnexTag receivePackDoneAttr $ T.pack $ show $ toi code
|
||||
where
|
||||
toi (ExitSuccess) = 0
|
||||
toi (ExitFailure i) = i
|
||||
|
||||
decodeReceivePackDone :: PushDecoder
|
||||
decodeReceivePackDone = mkPushDecoder $
|
||||
fmap (ReceivePackDone . convert) . readish . T.unpack . tagValue
|
||||
decodeMessage :: Message -> Maybe NetMessage
|
||||
decodeMessage m = decode =<< gitAnnexTagInfo m
|
||||
where
|
||||
convert 0 = ExitSuccess
|
||||
convert n = ExitFailure n
|
||||
decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
|
||||
rundecoder i d = d m i
|
||||
decoders = M.fromList $ zip
|
||||
[ pairAttr
|
||||
, canPushAttr
|
||||
, pushRequestAttr
|
||||
, startingPushAttr
|
||||
, receivePackAttr
|
||||
, sendPackAttr
|
||||
, receivePackDoneAttr
|
||||
]
|
||||
[ decodePairingNotification
|
||||
, mkPushDecoder $ const $ Just CanPush
|
||||
, mkPushDecoder $ const $ Just PushRequest
|
||||
, mkPushDecoder $ const $ Just StartingPush
|
||||
, mkPushDecoder $
|
||||
fmap ReceivePackOutput . decodeTagContent . tagElement
|
||||
, mkPushDecoder $
|
||||
fmap SendPackOutput . decodeTagContent . tagElement
|
||||
, mkPushDecoder $
|
||||
fmap (ReceivePackDone . convertCode) . readish .
|
||||
T.unpack . tagValue
|
||||
]
|
||||
|
||||
receivePackDoneAttr :: Name
|
||||
receivePackDoneAttr = "rpdone"
|
||||
convertCode :: Int -> ExitCode
|
||||
convertCode 0 = ExitSuccess
|
||||
convertCode n = ExitFailure n
|
||||
|
||||
{- Base 64 encoding a ByteString to use as the content of a tag. -}
|
||||
encodeTagContent :: ByteString -> [Node]
|
||||
|
|
@ -227,9 +199,36 @@ silentMessage = (emptyMessage MessageChat)
|
|||
extendedAway :: Element
|
||||
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
|
||||
|
||||
type PushDecoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
|
||||
type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
|
||||
|
||||
mkPushDecoder :: (GitAnnexTagInfo -> Maybe PushStage) -> PushDecoder
|
||||
mkPushDecoder :: (GitAnnexTagInfo -> Maybe PushStage) -> Decoder
|
||||
mkPushDecoder a m i = Pushing
|
||||
<$> (formatJID <$> messageFrom m)
|
||||
<*> a i
|
||||
|
||||
pushAttr :: Name
|
||||
pushAttr = "push"
|
||||
|
||||
queryAttr :: Name
|
||||
queryAttr = "query"
|
||||
|
||||
pairAttr :: Name
|
||||
pairAttr = "pair"
|
||||
|
||||
canPushAttr :: Name
|
||||
canPushAttr = "canpush"
|
||||
|
||||
pushRequestAttr :: Name
|
||||
pushRequestAttr = "pushrequest"
|
||||
|
||||
startingPushAttr :: Name
|
||||
startingPushAttr = "startingpush"
|
||||
|
||||
receivePackAttr :: Name
|
||||
receivePackAttr = "rp"
|
||||
|
||||
sendPackAttr :: Name
|
||||
sendPackAttr = "sp"
|
||||
|
||||
receivePackDoneAttr :: Name
|
||||
receivePackDoneAttr = "rpdone"
|
||||
|
|
|
|||
Loading…
Reference in a new issue