diff options
| -rw-r--r-- | src/Network/WireGuard/Internal/Data/RpcTypes.hs | 14 | ||||
| -rw-r--r-- | src/Network/WireGuard/Internal/RpcParsers.hs | 76 | ||||
| -rw-r--r-- | src/Network/WireGuard/RPC.hs | 101 |
3 files changed, 122 insertions, 69 deletions
diff --git a/src/Network/WireGuard/Internal/Data/RpcTypes.hs b/src/Network/WireGuard/Internal/Data/RpcTypes.hs index 7e1c20e..d3ec964 100644 --- a/src/Network/WireGuard/Internal/Data/RpcTypes.hs +++ b/src/Network/WireGuard/Internal/Data/RpcTypes.hs @@ -1,3 +1,15 @@ +{-| +Module : Network.WireGuard.Internal.Data.RpcTypes +Description : Collection of types used to communicate with the wg CLI utility. +Copyright : Félix Baylac-Jacqué, 2017 +License : GPL-3 +Maintainer : felix@alternativebit.fr +Stability : experimental +Portability : POSIX + +Collection of types used by to communicate with the wg CLI utility. +|-} + module Network.WireGuard.Internal.Data.RpcTypes( OpType(..), RpcRequest(..), @@ -51,6 +63,7 @@ instance Eq RpcDevicePayload where ((dhSecToBytes . fst) <$> pk1) == ((dhSecToBytes . fst) <$> pk2) && (prt1 == prt2) && (rp1 == rp2) && (fw1 == fw2) +-- | Key/Value couple of set device operations. data RpcDeviceField = RpcPk !(Maybe KeyPair) | RpcPort !Int | RpcFwMark !(Maybe Word) @@ -77,6 +90,7 @@ instance Show RpcPeerPayload where = show (dhPubToBytes pub1) ++ show rm1 ++ show psk1 ++ show e1 ++ show k1 ++ show rp1 ++ show aip1 +-- | Key/Value couple of set peer operations. data RpcPeerField = RpcRmFlag !Bool | RpcPsh !PresharedKey | RpcEndp !SockAddr diff --git a/src/Network/WireGuard/Internal/RpcParsers.hs b/src/Network/WireGuard/Internal/RpcParsers.hs index 654cf4e..6e23635 100644 --- a/src/Network/WireGuard/Internal/RpcParsers.hs +++ b/src/Network/WireGuard/Internal/RpcParsers.hs @@ -1,5 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} +{-| +Module : Network.WireGuard.Internal.RpcParsers +Description : Collection of parsers related to the communication with the wg CLI utility. +Copyright : Félix Baylac-Jacqué, 2017 +License : GPL-3 +Maintainer : felix@alternativebit.fr +Stability : experimental +Portability : POSIX + +Collection of attoparsec parsers related to the communication with the wg CLI utility. +|-} + module Network.WireGuard.Internal.RpcParsers( requestParser, deviceParser, @@ -34,7 +46,9 @@ import Network.WireGuard.Internal.Data.RpcTypes (OpType(..), RpcDeviceField(..), RpcPeerField(..)) --- | Attoparsec parser used to parse a RPC request, both Set or Get. +-- | Parses a RPC operation coming from the wg CLI. +-- +-- See <https://www.wireguard.com/xplatform/> for more informations about the RPC set operation. requestParser :: Parser RpcRequest requestParser = do op <- requestTypeParser @@ -44,16 +58,18 @@ requestParser = do _ <- string $ BC.pack "\n" return $ RpcRequest op p -requestTypeParser :: Parser OpType -requestTypeParser = "get=1\n" *> return Get - <|> "set=1\n" *> return Set - +-- | Parses a set operation. +-- +-- See <https://www.wireguard.com/xplatform/> for more informations about the RPC set operation. setPayloadParser :: Parser RpcSetPayload setPayloadParser = do dev <- deviceParser peers <- many' peerParser return $ RpcSetPayload dev peers +-- | Parses a device entry during a RPC set operation. +-- +-- See <https://www.wireguard.com/xplatform/> for more informations about the RPC set operation. deviceParser :: Parser RpcDevicePayload deviceParser = do fields <- deviceFieldsParser @@ -63,6 +79,35 @@ deviceParser = do let rmDev = not $ null [True | RpcReplacePeers <- fields] return $ RpcDevicePayload devPk p fw rmDev +-- | Parses a peer entry during a RPC set operation. +-- +-- See <https://www.wireguard.com/xplatform/> for more informations about the RPC set operation. +peerParser :: Parser RpcPeerPayload +peerParser = do + peerPubK <- parsePubKey + fields <- peerFieldsParser + let rm = not $ null [rmF | RpcRmFlag rmF <- fields] + let psh = listToMaybe [pshF | RpcPsh pshF <- fields] + let endPL = [endPF | RpcEndp endPF <- fields] + endP <- if null endPL + then fail "Cannot parse Peer endpoint" + else return $ head endPL + let ka = fromMaybe 0 $ listToMaybe [kaF | RpcKA kaF <- fields] + let rmIps = not $ null [rmIpsF | RpcDelIps rmIpsF <- fields] + let allIpR = [ipRF | RpcAllIp ipRF <- fields] + return $ RpcPeerPayload peerPubK rm psh endP ka rmIps allIpR + where + parsePubKey = do + _ <- "public_key=" <?> "Peer delimiter" + pubHex <- unhex <$> takeTill isEndOfLine :: Parser (Maybe ByteString) + _ <- "\n" + let pubMaybe = join $ (dhBytesToPub . BA.convert) <$> pubHex + maybe (fail "Cannot parse peer's public key") return pubMaybe + +requestTypeParser :: Parser OpType +requestTypeParser = "get=1\n" *> return Get + <|> "set=1\n" *> return Set + deviceFieldsParser :: Parser [RpcDeviceField] deviceFieldsParser = many' (deviceFieldParser <* endOfLine) @@ -85,27 +130,6 @@ deviceFieldParser = do return RpcReplacePeers _ -> fail "Not a device key" -peerParser :: Parser RpcPeerPayload -peerParser = do - peerPubK <- parsePubKey - fields <- peerFieldsParser - let rm = not $ null [rmF | RpcRmFlag rmF <- fields] - let psh = listToMaybe [pshF | RpcPsh pshF <- fields] - let endPL = [endPF | RpcEndp endPF <- fields] - endP <- if null endPL - then fail "Cannot parse Peer endpoint" - else return $ head endPL - let ka = fromMaybe 0 $ listToMaybe [kaF | RpcKA kaF <- fields] - let rmIps = not $ null [rmIpsF | RpcDelIps rmIpsF <- fields] - let allIpR = [ipRF | RpcAllIp ipRF <- fields] - return $ RpcPeerPayload peerPubK rm psh endP ka rmIps allIpR - where - parsePubKey = do - _ <- "public_key=" <?> "Peer delimiter" - pubHex <- unhex <$> takeTill isEndOfLine :: Parser (Maybe ByteString) - _ <- "\n" - let pubMaybe = join $ (dhBytesToPub . BA.convert) <$> pubHex - maybe (fail "Cannot parse peer's public key") return pubMaybe peerFieldsParser :: Parser [RpcPeerField] peerFieldsParser = many' (peerFieldParser <* endOfLine) 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 |