diff options
Diffstat (limited to 'src/Network/WireGuard/Internal')
| -rw-r--r-- | src/Network/WireGuard/Internal/Data/RpcTypes.hs | 60 | ||||
| -rw-r--r-- | src/Network/WireGuard/Internal/RpcParsers.hs | 167 |
2 files changed, 177 insertions, 50 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 + |