From 4cc3292d6c59e48f22cbcaae0ee2773c22c2bad9 Mon Sep 17 00:00:00 2001 From: Baylac-Jacqué Félix Date: Sat, 16 Sep 2017 16:54:24 +0200 Subject: Document RPC-related modules. --- src/Network/WireGuard/Internal/Data/RpcTypes.hs | 14 +++++ src/Network/WireGuard/Internal/RpcParsers.hs | 76 ++++++++++++++++--------- 2 files changed, 64 insertions(+), 26 deletions(-) (limited to 'src/Network/WireGuard/Internal') 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 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 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 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 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) -- cgit v1.2.3-59-g8ed1b