diff options
Diffstat (limited to 'src/Network/WireGuard/RPC.hs')
| -rw-r--r-- | src/Network/WireGuard/RPC.hs | 101 |
1 files changed, 58 insertions, 43 deletions
diff --git a/src/Network/WireGuard/RPC.hs b/src/Network/WireGuard/RPC.hs index 0175127..8fc6e82 100644 --- a/src/Network/WireGuard/RPC.hs +++ b/src/Network/WireGuard/RPC.hs @@ -1,10 +1,21 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-| +Module : Network.WireGuard.RPC +Description : Wireguard's RPC protocol implementation. +Copyright : Félix Baylac-Jacqué, 2017 +License : GPL-3 +Maintainer : felix@alternativebit.fr +Stability : experimental +Portability : POSIX + +Wireguard's RPC protocol implementation. This module contains +the various operation needed to communicate with the wg CLI utility. +|-} module Network.WireGuard.RPC ( runRPC, serveConduit, - bytesToPair, showDevice, showPeer ) where @@ -13,8 +24,7 @@ import Control.Concurrent.STM (STM, atomically, readTVar, writeTVar) import Control.Monad (when, unless) import Control.Monad.IO.Class (liftIO) -import qualified Crypto.Noise.DH as DH (dhPubToBytes, dhSecToBytes, - dhBytesToPair, dhBytesToPair) +import qualified Crypto.Noise.DH as DH (dhPubToBytes, dhSecToBytes) import qualified Data.ByteArray as BA (convert) import qualified Data.ByteString as BS (ByteString, concat, empty) @@ -35,26 +45,27 @@ import Data.Maybe (fromJust, isJust, import Network.WireGuard.Internal.RpcParsers (requestParser) import Network.WireGuard.Internal.State (Device(..), Peer(..), createPeer) -import Network.WireGuard.Internal.Data.Types (PrivateKey, PublicKey, - KeyPair) +import Network.WireGuard.Internal.Data.Types (PrivateKey, PublicKey) import Network.WireGuard.Internal.Data.RpcTypes (RpcRequest(..), RpcSetPayload(..), OpType(..), RpcDevicePayload(..), RpcPeerPayload(..)) import Network.WireGuard.Internal.Util (catchIOExceptionAnd) +--TODO: return appropriate errno during set operations. + -- | Run RPC service over a unix socket runRPC :: FilePath -> Device -> IO () runRPC sockPath device = runUnixServer (serverSettings sockPath) $ \app -> catchIOExceptionAnd (return ()) $ runConduit (appSource app .| serveConduit device .| appSink app) - --- TODO: ensure that all bytestring over sockets will be erased + +-- | Process a stream coming from a unix socket and writes back the +-- appropriate response. serveConduit :: Device -> ConduitM BS.ByteString BS.ByteString IO () serveConduit device = do request <- sinkParserEither requestParser routeRequest request where - --returnError = yield $ writeConfig (-invalidValueError) routeRequest (Left _) = yield mempty routeRequest (Right req) = case opType req of @@ -66,6 +77,45 @@ serveConduit device = do deviceBstr <- liftIO . atomically $ showDevice device yield $ BS.concat [deviceBstr, BC.pack "errno=0\n\n"] +-- | Print a device in a bytestring according to wireguard's RPC format. +-- +-- More infos about this format on this page <https://www.wireguard.com/xplatform/> +showDevice :: Device -> STM BS.ByteString +showDevice Device{..} = do + listen_port <- BC.pack . show <$> readTVar port + fwm <- BC.pack . show <$> readTVar fwmark + private_key <- fmap (toLowerBs . hex . privToBytes . fst) <$> readTVar localKey + let devHm = [("private_key", private_key), + ("listen_port", Just listen_port), + ("fwmark", Just fwm)] + let devBs = serializeRpcKeyValue devHm + prs <- readTVar peers + peersBstrList <- mapM showPeer $ HM.elems prs + return . BS.concat $ (devBs : peersBstrList) + +-- | Print a peer in a bytestring according to wireguard's RPC format. +-- +-- More infos about this format on this page <https://www.wireguard.com/xplatform/> +showPeer :: Peer -> STM BS.ByteString +showPeer Peer{..} = do + let public_key = pubToString remotePub + endpoint <- readTVar endPoint + persistant_keepalive_interval <- readTVar keepaliveInterval + allowed_ip <- readTVar ipmasks + rx_bytes <- readTVar receivedBytes + tx_bytes <- readTVar transferredBytes + last_handshake_time <- readTVar lastHandshakeTime + let peer = [("public_key", Just public_key), + ("endpoint", BC.pack . show <$> endpoint), + ("persistent_keepalive_interval", Just . BC.pack . show $ persistant_keepalive_interval), + ("tx_bytes", Just . BC.pack . show $ tx_bytes), + ("rx_bytes", Just . BC.pack . show $ rx_bytes), + ("last_handshake_time", BC.pack . show <$> last_handshake_time) + ] ++ expandAllowedIps (Just . BC.pack . show <$> allowed_ip) + return $ serializeRpcKeyValue peer + where + expandAllowedIps = foldr (\val acc -> ("allowed_ip", val):acc) [] + setDevice :: RpcRequest -> Device -> STM (Maybe BS.ByteString) setDevice req dev = do let devReq = devicePayload . fromJust $ payload req @@ -113,38 +163,6 @@ removePeer peer dev = do let nPeers = HM.delete (pubToString $ pubK peer) currentPeers writeTVar (peers dev) nPeers -showDevice :: Device -> STM BS.ByteString -showDevice Device{..} = do - listen_port <- BC.pack . show <$> readTVar port - fwm <- BC.pack . show <$> readTVar fwmark - private_key <- fmap (toLowerBs . hex . privToBytes . fst) <$> readTVar localKey - let devHm = [("private_key", private_key), - ("listen_port", Just listen_port), - ("fwmark", Just fwm)] - let devBs = serializeRpcKeyValue devHm - prs <- readTVar peers - peersBstrList <- mapM showPeer $ HM.elems prs - return . BS.concat $ (devBs : peersBstrList) - -showPeer :: Peer -> STM BS.ByteString -showPeer Peer{..} = do - let public_key = pubToString remotePub - endpoint <- readTVar endPoint - persistant_keepalive_interval <- readTVar keepaliveInterval - allowed_ip <- readTVar ipmasks - rx_bytes <- readTVar receivedBytes - tx_bytes <- readTVar transferredBytes - last_handshake_time <- readTVar lastHandshakeTime - let peer = [("public_key", Just public_key), - ("endpoint", BC.pack . show <$> endpoint), - ("persistent_keepalive_interval", Just . BC.pack . show $ persistant_keepalive_interval), - ("tx_bytes", Just . BC.pack . show $ tx_bytes), - ("rx_bytes", Just . BC.pack . show $ rx_bytes), - ("last_handshake_time", BC.pack . show <$> last_handshake_time) - ] ++ expandAllowedIps (Just . BC.pack . show <$> allowed_ip) - return $ serializeRpcKeyValue peer - where - expandAllowedIps = foldr (\val acc -> ("allowed_ip", val):acc) [] serializeRpcKeyValue :: [(String, Maybe BS.ByteString)] -> BS.ByteString serializeRpcKeyValue = foldl' showKeyValueLine BS.empty @@ -163,8 +181,5 @@ pubToString = toLowerBs . hex . pubToBytes privToBytes :: PrivateKey -> BS.ByteString privToBytes = BA.convert . DH.dhSecToBytes -bytesToPair :: BS.ByteString -> Maybe KeyPair -bytesToPair = DH.dhBytesToPair . BA.convert - toLowerBs :: BS.ByteString -> BS.ByteString toLowerBs = BC.map toLower |