{-# 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, peerParser, setPayloadParser ) where import Control.Applicative ((*>), (<|>)) import Control.Monad (join) import Crypto.Noise.DH (dhBytesToPair, dhBytesToPub) import Data.Attoparsec.ByteString.Char8 (Parser, string, 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 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(..), RpcDeviceField(..), RpcPeerField(..)) -- | 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 p <- case op of Set -> Just <$> setPayloadParser Get -> return Nothing _ <- string $ BC.pack "\n" return $ RpcRequest op p -- | 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 let devPk = 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 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) 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" 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) 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