aboutsummaryrefslogtreecommitdiffstats
path: root/src/Network/WireGuard/Internal/RpcParsers.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/WireGuard/Internal/RpcParsers.hs')
-rw-r--r--src/Network/WireGuard/Internal/RpcParsers.hs167
1 files changed, 136 insertions, 31 deletions
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
+