aboutsummaryrefslogtreecommitdiffstats
path: root/src/Network
diff options
context:
space:
mode:
authorBaylac-Jacqué Félix <felix@alternativebit.fr>2017-09-09 16:44:19 +0200
committerBaylac-Jacqué Félix <felix@alternativebit.fr>2017-09-16 17:10:57 +0200
commitb888759a791e62654a046c22221012f1cff4285a (patch)
tree5a41e05d5f06d96e9b3abca66c638d439eb09982 /src/Network
parentExtracted RPC types to proper module. (diff)
downloadwireguard-hs-b888759a791e62654a046c22221012f1cff4285a.tar.xz
wireguard-hs-b888759a791e62654a046c22221012f1cff4285a.zip
Implemented RPC parsers.
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/WireGuard/Internal/Data/RpcTypes.hs60
-rw-r--r--src/Network/WireGuard/Internal/RpcParsers.hs167
-rw-r--r--src/Network/WireGuard/RPC.hs9
3 files changed, 181 insertions, 55 deletions
diff --git a/src/Network/WireGuard/Internal/Data/RpcTypes.hs b/src/Network/WireGuard/Internal/Data/RpcTypes.hs
index a3c148b..d45d38e 100644
--- a/src/Network/WireGuard/Internal/Data/RpcTypes.hs
+++ b/src/Network/WireGuard/Internal/Data/RpcTypes.hs
@@ -3,16 +3,17 @@ module Network.WireGuard.Internal.Data.RpcTypes(
RpcRequest(..),
RpcSetPayload(..),
RpcDevicePayload(..),
- RpcPeerPayload(..)
+ RpcPeerPayload(..),
+ RpcDeviceField(..),
+ RpcPeerField(..)
) where
-import Data.Word (Word64)
import Data.IP (IPRange(..))
-import Crypto.Noise.DH (dhSecToBytes)
+import Crypto.Noise.DH (dhSecToBytes, dhPubToBytes)
import Network.Socket.Internal (SockAddr)
import Network.WireGuard.Internal.Data.Types (PublicKey, KeyPair,
- Time)
+ PresharedKey)
-- | Kind of client operation.
--
-- See <https://www.wireguard.com/xplatform/#configuration-protocol> for more informations.
@@ -22,22 +23,22 @@ data OpType = Get | Set
--
-- See <https://www.wireguard.com/xplatform/#configuration-protocol> for more informations.
data RpcRequest = RpcRequest {
- opType :: OpType,
- payload :: Maybe RpcSetPayload
+ opType :: !OpType,
+ payload :: !(Maybe RpcSetPayload)
}
-- | Payload sent together with a set RPC operation.
data RpcSetPayload = RpcSetPayload {
- devicePayload :: RpcDevicePayload,
+ devicePayload :: !RpcDevicePayload,
peersPayload :: [RpcPeerPayload]
}
-- | Device related payload sent together with a set RPC operation.
data RpcDevicePayload = RpcDevicePayload {
- pk :: Maybe KeyPair,
- listenPort :: Int,
- fwMark :: Maybe Word,
- replacePeers :: Bool
+ pk :: !(Maybe KeyPair),
+ listenPort :: !Int,
+ fwMark :: !(Maybe Word),
+ replacePeers :: !Bool
}
instance Show RpcDevicePayload where
@@ -50,14 +51,35 @@ instance Eq RpcDevicePayload where
((dhSecToBytes . fst) <$> pk1) == ((dhSecToBytes . fst) <$> pk2) && (prt1 == prt2) &&
(rp1 == rp2) && (fw1 == fw2)
+data RpcDeviceField = RpcPk !(Maybe KeyPair)
+ | RpcPort !Int
+ | RpcFwMark !(Maybe Word)
+ | RpcReplacePeers
+
-- | Peer related payload sent together with a set RPC operation.
data RpcPeerPayload = RpcPeerPayload {
- pubK :: PublicKey,
- remove :: Bool,
- endpoint :: SockAddr,
- persistantKeepaliveInterval :: Int,
- allowedIp :: [IPRange],
- rxBytes :: Word64,
- txBytes :: Word64,
- lastHandshake :: Time
+ pubK :: !PublicKey,
+ remove :: !Bool,
+ presharedKey :: !(Maybe PresharedKey),
+ endpoint :: !SockAddr,
+ persistantKeepaliveInterval :: !Int,
+ replaceIps :: !Bool,
+ allowedIp :: ![IPRange]
}
+
+instance Eq RpcPeerPayload where
+ (==) (RpcPeerPayload pub1 rm1 psk1 e1 k1 rp1 aip1)(RpcPeerPayload pub2 rm2 psk2 e2 k2 rp2 aip2) =
+ (dhPubToBytes pub1 == dhPubToBytes pub2) && (rm1 == rm2) && (psk1 == psk2) && (e1 == e2) &&
+ (k1 == k2) && (rp1 == rp2) && (aip1 == aip2)
+
+instance Show RpcPeerPayload where
+ show (RpcPeerPayload pub1 rm1 psk1 e1 k1 rp1 aip1)
+ = show (dhPubToBytes pub1) ++ show rm1 ++ show psk1 ++ show e1 ++ show k1 ++
+ show rp1 ++ show aip1
+
+data RpcPeerField = RpcRmFlag !Bool
+ | RpcPsh !PresharedKey
+ | RpcEndp !SockAddr
+ | RpcKA !Int
+ | RpcDelIps !Bool
+ | RpcAllIp !IPRange
diff --git a/src/Network/WireGuard/Internal/RpcParsers.hs b/src/Network/WireGuard/Internal/RpcParsers.hs
index b28b000..c5179c8 100644
--- a/src/Network/WireGuard/Internal/RpcParsers.hs
+++ b/src/Network/WireGuard/Internal/RpcParsers.hs
@@ -1,39 +1,37 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.WireGuard.Internal.RpcParsers(
- RpcRequest(..),
- OpType(..),
- RpcSetPayload(..),
- RpcDevicePayload(..),
- RpcPeerPayload(..),
requestParser,
- deviceParser
+ deviceParser,
+ peerParser
) where
-
import Control.Applicative ((*>), (<|>))
-import Control.Monad (liftM, join)
-import Crypto.Noise.DH (dhSecToBytes, dhBytesToPair)
+import Control.Monad (join)
+import Crypto.Noise.DH (dhBytesToPair, dhBytesToPub)
import Data.Attoparsec.ByteString.Char8 (Parser, string,
- takeTill, option)
-import Data.Attoparsec.Combinator ((<?>))
-import qualified Data.ByteArray as BA (convert)
-import qualified Data.ByteString as BS (head)
-import Data.ByteString.Conversion
-import qualified Data.ByteString.Char8 as BC (pack)
-import Data.Maybe (fromMaybe)
-import Data.IP (IPRange(..))
-import Data.Hex (unhex)
-import Data.Word (Word, Word64)
+ takeTill, option,
+ endOfLine, peekChar')
+import Data.Attoparsec.Text (isEndOfLine)
+import Data.Attoparsec.Combinator ((<?>), many')
+import qualified Data.ByteArray as BA (convert, )
import Data.ByteString (ByteString)
-import Network.Socket.Internal (SockAddr)
+import Data.ByteString.Conversion (fromByteString)
+import qualified Data.ByteString.Char8 as BC (pack, unpack)
+import Data.Maybe (fromMaybe, listToMaybe,
+ fromJust)
+import Data.IP (IPRange, toHostAddress6)
+import Data.Hex (unhex)
+import Network.Socket (SockAddr, tupleToHostAddress,
+ SockAddr(..))
import Network.WireGuard.Internal.Data.RpcTypes (OpType(..),
RpcRequest(..),
RpcDevicePayload(..),
RpcPeerPayload(..),
- RpcSetPayload(..))
-
+ RpcSetPayload(..),
+ RpcDeviceField(..),
+ RpcPeerField(..))
-- | Attoparsec parser used to parse a RPC request, both Set or Get.
requestParser :: Parser RpcRequest
@@ -54,13 +52,120 @@ setPayloadParser = undefined
deviceParser :: Parser RpcDevicePayload
deviceParser = do
- pkHex <- option Nothing (unhex <$> keyParser "private_key") <?> "Primary key parser"
- "\n"
- let pk = join $ (dhBytesToPair . BA.convert) <$> pkHex
- p <- (fromMaybe 0 . fromByteString) <$> keyParser "listen_port" <?> "Port parser"
- "\n"
- fwmark <- option Nothing (fromByteString <$> keyParser "fwmark") <?> "Fwmark parser"
- return $ RpcDevicePayload pk p fwmark False
+ fields <- deviceFieldsParser
+ let pk = join $ listToMaybe [ pkF | RpcPk pkF <- fields]
+ let p = head [ pF | RpcPort pF <- fields]
+ let fw = join $ listToMaybe [ fwF | RpcFwMark fwF <- fields]
+ let rmDev = not $ null [True | RpcReplacePeers <- fields]
+ return $ RpcDevicePayload pk p fw rmDev
+
+deviceFieldsParser :: Parser [RpcDeviceField]
+deviceFieldsParser = many' (deviceFieldParser <* endOfLine)
+
+deviceFieldParser :: Parser RpcDeviceField
+deviceFieldParser = do
+ key <- takeTill (=='=')
+ _ <- "="
+ case key of
+ "private_key" -> do
+ pkHex <- option Nothing (unhex <$> takeTill isEndOfLine) <?> "Primary Key parser"
+ return . RpcPk . join $ (dhBytesToPair . BA.convert) <$> pkHex
+ "listen_port" -> do
+ p <- (fromMaybe 0 . fromByteString) <$> takeTill isEndOfLine <?> "Listen Port parser"
+ return $ RpcPort p
+ "fwmark" -> do
+ fwmark <- option Nothing (fromByteString <$> takeTill isEndOfLine) <?> "fwmark parser"
+ return $ RpcFwMark fwmark
+ "replace_peers" -> do
+ _ <- "true"
+ return RpcReplacePeers
+ _ -> fail "Not a device key"
+
+peerParser :: Parser RpcPeerPayload
+peerParser = do
+ pubK <- 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 pubK 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)
+
+peerFieldParser :: Parser RpcPeerField
+peerFieldParser = do
+ key <- takeTill (=='=')
+ _ <- "="
+ case key of
+ "remove" -> (do
+ _ <- "true"
+ return $ RpcRmFlag True) <?> "Remove peer parser"
+ "preshared_key" -> (do
+ pshHex <- unhex <$> takeTill isEndOfLine
+ return . RpcPsh . BA.convert . fromJust $ pshHex) <?> "Psh key peer parser"
+ "endpoint" -> RpcEndp <$> parseIpAddress <?> "Endpoint peer parser"
+ "persistent_keepalive_interval" -> (RpcKA . read . BC.unpack) <$> takeTill isEndOfLine <?> "Persistant keepalive parser"
+ "replace_allowed_ips" -> (do
+ _ <- "true"
+ return $ RpcDelIps True) <?> "Replace allowed Ips parser"
+ "allowed_ip" -> RpcAllIp <$> parseIpRange <?> "Allowed ips parser"
+ _ -> fail "Not a peer key"
+
+parseIpAddress :: Parser SockAddr
+parseIpAddress = do
+ f <- peekChar'
+ if f == '['
+ then parseIpv6
+ else parseIpv4
+ where
+ parseIpv6 = do
+ _ <- "["
+ host1 <- (fromJust . fromByteString) <$> takeTill (=='%')
+ _ <- "%"
+ scope_id <- (fromJust . fromByteString) <$> takeTill (==']')
+ _ <- "]:"
+ port <- (read . fromJust . fromByteString) <$> takeTill isEndOfLine
+ let host = toHostAddress6 $ read host1
+ return $ SockAddrInet6 port 0 host scope_id
+ parseIpv4 = do
+ ip1 <- (fromJust . fromByteString) <$> takeTill (=='.')
+ _ <- "."
+ ip2 <- (fromJust . fromByteString) <$> takeTill (=='.')
+ _ <- "."
+ ip3 <- (fromJust . fromByteString) <$> takeTill (=='.')
+ _ <- "."
+ ip4 <- (fromJust . fromByteString) <$> takeTill (==':')
+ _ <- ":"
+ p <- (fromInteger . fromJust . fromByteString) <$> takeTill isEndOfLine
+ return . SockAddrInet p $ tupleToHostAddress (ip1,ip2,ip3,ip4)
-keyParser :: ByteString -> Parser ByteString
-keyParser str = (string str *> "=") *> takeTill (=='\n')
+parseIpRange :: Parser IPRange
+parseIpRange = do
+ f <- peekChar'
+ if f == '['
+ then parseIpv6Range
+ else parseIpv4Range
+ where
+ parseIpv4Range = do
+ line <- takeTill isEndOfLine
+ return . read . fromJust $ fromByteString line
+ parseIpv6Range = do
+ _ <- "["
+ rng <- takeTill (==']')
+ _ <- "]"
+ return . read . fromJust $ fromByteString rng
+
diff --git a/src/Network/WireGuard/RPC.hs b/src/Network/WireGuard/RPC.hs
index ae9e552..162b5b4 100644
--- a/src/Network/WireGuard/RPC.hs
+++ b/src/Network/WireGuard/RPC.hs
@@ -1,9 +1,7 @@
{-# LANGUAGE RecordWildCards #-}
module Network.WireGuard.RPC
- ( OpType(..),
- RpcRequest(..),
- runRPC,
+ ( runRPC,
serveConduit,
bytesToPair,
showDevice,
@@ -47,13 +45,14 @@ import Network.WireGuard.Foreign.UAPI (WgPeer(..), WgDevice
deviceFlagRemoveFwmark, deviceFlagReplacePeers,
deviceFlagRemovePrivateKey, deviceFlagRemovePresharedKey)
import Network.WireGuard.Internal.Constant (keyLength)
-import Network.WireGuard.Internal.RpcParsers (RpcRequest(..), RpcSetPayload(..),
- OpType(..), requestParser)
+import Network.WireGuard.Internal.RpcParsers (requestParser)
import Network.WireGuard.Internal.State (Device(..), Peer(..),
createPeer,
invalidateSessions)
import Network.WireGuard.Internal.Data.Types (PrivateKey, PublicKey,
PresharedKey, KeyPair)
+import Network.WireGuard.Internal.Data.RpcTypes (RpcRequest(..), RpcSetPayload(..),
+ OpType(..))
import Network.WireGuard.Internal.Util (catchIOExceptionAnd)
-- | Run RPC service over a unix socket