From 753793371aa6595e41b095952f5d67563e103290 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 1 Dec 2016 00:41:01 -0400 Subject: cleanups --- CmdLine/GitRemoteTorAnnex.hs | 2 +- P2P/IO.hs | 33 ++++++++++++++++++--------------- P2P/Protocol.hs | 32 -------------------------------- RemoteDaemon/Transport/Tor.hs | 2 +- 4 files changed, 20 insertions(+), 49 deletions(-) diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index 72211c995..517ce7c82 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -66,7 +66,7 @@ connectService address port service = do , runIhdl = h , runOhdl = h } - runNetProtoHandle runenv $ do + liftIO $ runNetProto runenv $ do v <- auth myuuid authtoken case v of Just _theiruuid -> connect service stdin stdout diff --git a/P2P/IO.hs b/P2P/IO.hs index ac7c3e463..6a834c659 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -1,4 +1,4 @@ -{- P2P protocol, partial IO implementation +{- P2P protocol, IO implementation - - Copyright 2016 Joey Hess - @@ -9,8 +9,8 @@ module P2P.IO ( RunEnv(..) - , runNetProtoHandle - , runNetHandle + , runNetProto + , runNet ) where import P2P.Protocol @@ -42,21 +42,25 @@ data RunEnv = RunEnv , runOhdl :: Handle } --- Interpreter of Proto that communicates with a peer over a Handle. +-- Purposefully incomplete interpreter of Proto. -- --- No Local actions will be run; if the interpreter reaches any, +-- This only runs Net actions. No Local actions will be run +-- (those need the Annex monad) -- if the interpreter reaches any, -- it returns Nothing. -runNetProtoHandle :: (MonadIO m, MonadMask m) => RunEnv -> Proto a -> m (Maybe a) -runNetProtoHandle runenv = go +runNetProto :: RunEnv -> Proto a -> IO (Maybe a) +runNetProto runenv = go where - go :: RunProto m + go :: RunProto IO go (Pure v) = pure (Just v) - go (Free (Net n)) = runNetHandle runenv go n + go (Free (Net n)) = runNet runenv go n go (Free (Local _)) = return Nothing --- Interprater of Net that communicates with a peer over a Handle. -runNetHandle :: (MonadIO m, MonadMask m) => RunEnv -> RunProto m -> NetF (Proto a) -> m (Maybe a) -runNetHandle runenv runner f = case f of +-- Interprater of the Net part of Proto. +-- +-- An interpreter of Proto has to be provided, to handle the rest of Proto +-- actions. +runNet :: (MonadIO m, MonadMask m) => RunEnv -> RunProto m -> NetF (Proto a) -> m (Maybe a) +runNet runenv runner f = case f of SendMessage m next -> do v <- liftIO $ tryIO $ do hPutStrLn (runOhdl runenv) (unwords (formatMessage m)) @@ -101,10 +105,9 @@ runNetHandle runenv runner f = case f of Just () -> runner next where -- This is only used for running Net actions when relaying, - -- so it's ok to use runNetProtoHandle, despite it not supporting + -- so it's ok to use runNetProto, despite it not supporting -- all Proto actions. - runnerio :: RunProto IO - runnerio = runNetProtoHandle runenv + runnerio = runNetProto runenv runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Maybe ExitCode) runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index 381949af1..444e08f0e 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -174,38 +174,6 @@ type Local = Free LocalF $(makeFree ''NetF) $(makeFree ''LocalF) --- | Running Proto actions purely, to see what they do. -runPure :: Show r => Proto r -> [Message] -> [(String, Maybe Message)] -runPure (Pure r) _ = [("result: " ++ show r, Nothing)] -runPure (Free (Net n)) ms = runNet n ms -runPure (Free (Local n)) ms = runLocal n ms - -runNet :: Show r => NetF (Proto r) -> [Message] -> [(String, Maybe Message)] -runNet (SendMessage m next) ms = (">", Just m):runPure next ms -runNet (ReceiveMessage _) [] = [("not enough Messages provided", Nothing)] -runNet (ReceiveMessage next) (m:ms) = ("<", Just m):runPure (next m) ms -runNet (SendBytes _ _ next) ms = ("> bytes", Nothing):runPure next ms -runNet (ReceiveBytes _ next) ms = ("< bytes", Nothing):runPure (next L.empty) ms -runNet (CheckAuthToken _ _ next) ms = runPure (next True) ms -runNet (Relay _ _ next) ms = runPure (next ExitSuccess) ms -runNet (RelayService _ next) ms = runPure next ms - -runLocal :: Show r => LocalF (Proto r) -> [Message] -> [(String, Maybe Message)] -runLocal (KeyFileSize _ next) ms = runPure (next (Len 100)) ms -runLocal (ReadKeyFile _ _ next) ms = runPure (next L.empty) ms -runLocal (WriteKeyFile _ _ _ _ next) ms = runPure (next True) ms -runLocal (SetPresent _ _ next) ms = runPure next ms -runLocal (CheckContentPresent _ next) ms = runPure (next False) ms -runLocal (RemoveKeyFile _ next) ms = runPure (next True) ms -runLocal (TryLockContent _ p next) ms = runPure (p True >> next) ms - -protoDump :: [(String, Maybe Message)] -> String -protoDump = unlines . map protoDump' - -protoDump' :: (String, Maybe Message) -> String -protoDump' (s, Nothing) = s -protoDump' (s, Just m) = s ++ " " ++ unwords (Proto.formatMessage m) - auth :: UUID -> AuthToken -> Proto (Maybe UUID) auth myuuid t = do net $ sendMessage (AUTH myuuid t) diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 172948d37..75b1a7923 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -84,5 +84,5 @@ serveClient th u r q = bracket setup cleanup go , runIhdl = h , runOhdl = h } - void $ runNetProtoHandle runenv (serve u) + void $ runNetProto runenv (serve u) debugM "remotedaemon" "done with TOR connection" -- cgit v1.2.3