diff options
| -rw-r--r-- | nara.cabal | 6 | ||||
| -rw-r--r-- | src/Network/WireGuard/RPC.hs | 159 | ||||
| -rw-r--r-- | tests/spec/Network/WireGuard/RPCSpec.hs | 106 |
3 files changed, 185 insertions, 86 deletions
@@ -71,6 +71,7 @@ library directory, exceptions, filepath, + hex, iproute == 1.7.*, lens, memory == 0.14.*, @@ -119,6 +120,11 @@ test-suite nara-test , conduit-extra , conduit , stm + , memory + , cacophony + , hex + , network + , iproute other-modules: Network.WireGuard.RPCSpec default-language: Haskell2010 diff --git a/src/Network/WireGuard/RPC.hs b/src/Network/WireGuard/RPC.hs index 76f5d63..73d9e7a 100644 --- a/src/Network/WireGuard/RPC.hs +++ b/src/Network/WireGuard/RPC.hs @@ -1,8 +1,13 @@ {-# LANGUAGE RecordWildCards #-} module Network.WireGuard.RPC - ( runRPC, - serveConduit + ( OpType(..), + RpcRequest(..), + runRPC, + serveConduit, + bytesToPair, + showDevice, + showPeer ) where import Control.Concurrent.STM (STM, atomically, @@ -16,22 +21,27 @@ import qualified Crypto.Noise.DH as DH (dhPubToBytes, dhSecT dhBytesToPub) import qualified Data.ByteArray as BA (convert) import qualified Data.ByteString as BS (ByteString, concat, - replicate) -import qualified Data.ByteString.Lazy.Char8 as CL (pack) -import qualified Data.Conduit.Binary as CB (sinkStorable, take) + replicate, empty, pack) +import qualified Data.ByteString.Lazy.Char8 as CL (unpack) +import qualified Data.ByteString.Char8 as BC (pack, singleton, map) +import Data.Char (toLower) +import qualified Data.Conduit.Binary as CB (sinkStorable, sinkLbs) import Data.Conduit.Network.Unix (appSink, appSource, runUnixServer, serverSettings) -import qualified Data.HashMap.Strict as HM (size, delete, +import qualified Data.HashMap.Strict as HM (HashMap(..), size, delete, lookup, insert, - empty) + empty, fromList, + foldrWithKey, elems) +import Data.Hex (hex) import Data.Int (Int32) -import Data.List (genericLength) +import Data.List (foldl', genericLength) import Foreign.C.Types (CTime (..)) import Data.Bits (Bits(..)) import Data.Conduit (ConduitM, (.|), - yield, runConduit) + yield, runConduit, + toConsumer) import Data.IP (IPRange(..), addrRangePair, toHostAddress, toHostAddress6, fromHostAddress, makeAddrRange, @@ -51,74 +61,84 @@ import Network.WireGuard.Internal.Types (PrivateKey, PublicKe PresharedKey, KeyPair) import Network.WireGuard.Internal.Util (catchIOExceptionAnd) +-- | Kind of client operation. +-- +-- See <https://www.wireguard.com/xplatform/#configuration-protocol> for more informations. +data OpType = Get | Set + +-- | Request wrapper. The payload is set only for Set operations. +-- +-- See <https://www.wireguard.com/xplatform/#configuration-protocol> for more informations. +data RpcRequest = RpcRequest { + opType :: OpType, + payload :: BS.ByteString +} + -- | Run RPC service over a unix socket runRPC :: FilePath -> Device -> IO () runRPC sockPath device = runUnixServer (serverSettings sockPath) $ \app -> - catchIOExceptionAnd (return ()) $ runConduit (appSource app .| serveConduit device .| appSink app) + catchIOExceptionAnd (return ()) $ + runConduit (appSource app .| serveConduit device .| appSink app) -- TODO: ensure that all bytestring over sockets will be erased serveConduit :: Device -> ConduitM BS.ByteString BS.ByteString IO () serveConduit device = do - line <- CB.take 5 - case () of _ - | isGet line -> showDevice device - | isSet line -> undefined - | otherwise -> mempty + request <- CL.unpack <$> toConsumer CB.sinkLbs + if request /= "" + then routeRequest request + else yield mempty where --returnError = yield $ writeConfig (-invalidValueError) - isGet = (== CL.pack "get=1") - isSet = (== CL.pack "set=1") - - showDevice Device{..} = do - (wgdevice, peers') <- liftIO buildWgDevice - yield (writeConfig wgdevice) - mapM_ showPeer peers' - where - buildWgDevice = atomically $ do - localKey' <- readTVar localKey - let (pub, priv) = case localKey' of - Nothing -> (emptyKey, emptyKey) - Just (sec, pub') -> (pubToBytes pub', privToBytes sec) - psk' <- fmap pskToBytes <$> readTVar presharedKey - fwmark' <- fromIntegral <$> readTVar fwmark - port' <- fromIntegral <$> readTVar port - peers' <- readTVar peers - return (WgDevice intfName 0 pub priv (fromMaybe emptyKey psk') - fwmark' port' (fromIntegral $ HM.size peers'), peers') - - showPeer Peer{..} = do - (wgpeer, ipmasks') <- liftIO buildWgPeer - yield (writeConfig wgpeer) - yield $ BS.concat (map (writeConfig . ipRangeToWgIpmask) ipmasks') - where - extractTime Nothing = 0 - extractTime (Just (CTime t)) = fromIntegral t - - buildWgPeer = atomically $ do - ipmasks' <- readTVar ipmasks - wgpeer <- WgPeer (pubToBytes remotePub) - <$> return 0 - <*> readTVar endPoint - <*> (extractTime <$> readTVar lastHandshakeTime) - <*> (fromIntegral <$> readTVar receivedBytes) - <*> (fromIntegral <$> readTVar transferredBytes) - <*> (fromIntegral <$> readTVar keepaliveInterval) - <*> return (genericLength ipmasks') - return (wgpeer, ipmasks') - - updateDevice wgdevice = do - setPeerMs <- replicateM (fromIntegral $ deviceNumPeers wgdevice) $ do - Just wgpeer <- CB.sinkStorable - -- TODO: replace fromJust - ipranges <- replicateM (fromIntegral $ peerNumIpmasks wgpeer) - (wgIpmaskToIpRange . fromJust <$> CB.sinkStorable) - return $ setPeer device wgpeer ipranges - liftIO $ atomically $ do - setDevice device wgdevice - anyIpMaskChanged <- or <$> sequence setPeerMs - -- TODO: modify routetable incrementally - when anyIpMaskChanged $ buildRouteTables device - yield $ writeConfig (0 :: Int32) + isGet = (== "get=1") + isSet = (== "set=1") + routeRequest req = do + let line = head $ lines req + case () of _ + | isGet line -> do + deviceBstr <- liftIO . atomically $ showDevice device + yield deviceBstr + | otherwise -> yield mempty + +showDevice :: Device -> STM BS.ByteString +showDevice device@Device{..} = do + listen_port <- BC.pack . show <$> readTVar port + fwmark <- BC.pack . show <$> readTVar fwmark + private_key <- fmap (toLowerBs . hex . privToBytes . fst) <$> readTVar localKey + let devHm = [("private_key", private_key), + ("listen_port", Just listen_port), + ("fwmark", Just fwmark)] + let devBs = serializeRpcKeyValue devHm + peers <- readTVar peers + peersBstrList <- mapM showPeer $ HM.elems peers + return . BS.concat $ (devBs : peersBstrList ++ [BC.singleton '\n']) + +showPeer :: Peer -> STM BS.ByteString +showPeer Peer{..} = do + let hm = HM.empty + let public_key = toLowerBs . hex $ pubToBytes remotePub + endpoint <- readTVar endPoint + persistant_keepalive_interval <- readTVar keepaliveInterval + allowed_ip <- readTVar ipmasks + rx_bytes <- readTVar receivedBytes + tx_bytes <- readTVar transferredBytes + last_handshake_time <- readTVar lastHandshakeTime + let peer = [("public_key", Just public_key), + ("endpoint", BC.pack . show <$> endpoint), + ("persistant_keepalive_interval", Just . BC.pack . show $ persistant_keepalive_interval), + ("rx_bytes", Just . BC.pack . show $ rx_bytes), + ("tx_bytes", Just . BC.pack . show $ tx_bytes), + ("last_handshake_time", BC.pack . show <$> last_handshake_time) + ] ++ expandAllowedIps (Just . BC.pack . show <$> allowed_ip) + return $ serializeRpcKeyValue peer + where + expandAllowedIps = foldr (\val acc -> ("allowed_ip", val):acc) [] + +serializeRpcKeyValue :: [(String, Maybe BS.ByteString)] -> BS.ByteString +serializeRpcKeyValue = foldl' showKeyValueLine BS.empty + where + showKeyValueLine acc (key, Just val) = BS.concat [acc, BC.pack key, BC.singleton '=', val, BC.singleton '\n'] + showKeyValueLine acc (_, Nothing) = acc + -- | implementation of config.c::set_peer() setPeer :: Device -> WgPeer -> [IPRange] -> STM Bool @@ -201,3 +221,6 @@ bytesToPub = DH.dhBytesToPub . BA.convert bytesToPSK :: BS.ByteString -> PresharedKey bytesToPSK = BA.convert + +toLowerBs :: BS.ByteString -> BS.ByteString +toLowerBs = BC.map toLower diff --git a/tests/spec/Network/WireGuard/RPCSpec.hs b/tests/spec/Network/WireGuard/RPCSpec.hs index 5a33d80..6d40e18 100644 --- a/tests/spec/Network/WireGuard/RPCSpec.hs +++ b/tests/spec/Network/WireGuard/RPCSpec.hs @@ -1,35 +1,105 @@ module Network.WireGuard.RPCSpec (spec) where import Control.Monad.STM (atomically, STM) +import Control.Concurrent.STM.TVar (writeTVar) +import qualified Data.ByteArray as BA (convert) import qualified Data.ByteString as BS (ByteString) -import qualified Data.ByteString.Lazy as BSL (ByteString) +import qualified Data.ByteString.Lazy as BSL (ByteString, isSuffixOf) import qualified Data.ByteString.Char8 as BC (pack) import qualified Data.ByteString.Lazy.Char8 as BCL (pack) +import Data.Maybe (fromJust) +import Data.Hex (unhex) +import Data.IP (AddrRange, IPv4, IPRange(..)) +import qualified Crypto.Noise.DH as DH (dhBytesToPair, dhBytesToPub) import Data.Conduit (runConduit, yield, ( .|)) import Data.Conduit.Binary (sinkLbs) +import Network.Socket (SockAddr(..), tupleToHostAddress) import Test.Hspec (Spec, describe, it, shouldBe, - shouldNotBe) + shouldSatisfy) +import Network.WireGuard.RPC (serveConduit, showPeer) +import Network.WireGuard.Internal.State (Device(..), Peer(..), + createDevice, createPeer) +import Network.WireGuard.Internal.Types (PresharedKey) -import Network.WireGuard.RPC (serveConduit) -import Network.WireGuard.Internal.State (Device, createDevice) +spec :: Spec +spec = do + describe "serveConduit" $ do + it "must correctly respond to a malformed request" $ do + devStm <- testDevice + device <- atomically devStm + res <- runConduit (yield (BC.pack "") .| serveConduit device .| sinkLbs) + res `shouldBe` BCL.pack "" + it "must correctly respond to an empty request" $ do + devStm <- testDevice + device <- atomically devStm + res <- runConduit (yield (BC.pack "\n\n") .| serveConduit device .| sinkLbs) + res `shouldBe` BCL.pack "" + it "must respond to a correctly formed get v1 request" $ do + devStm <- testDevice + device <- atomically devStm + res <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit device .| sinkLbs) + res `shouldBe` bsTestDevice + chkCorrectEnd res + describe "showPeer" $ do + it "must correctly generate a complete peer bytestring containing one ip range" $ do + peerPub <- unhex $ BC.pack "662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58" + peer <- atomically $ getTestPeerOneRange peerPub + res <- atomically $ showPeer peer + res `shouldBe` BC.pack "public_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=192.168.1.1:1337\npersistant_keepalive_interval=0\nrx_bytes=777\ntx_bytes=778\nlast_handshake_time=1502895867\nallowed_ip=192.168.1.0/24\n" + it "must correctly generate a complete peer bytestring containing several ip ranges" $ do + peerPub <- unhex $ BC.pack "662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58" + peer <- atomically $ getTestPeerTwoRanges peerPub + res <- atomically $ showPeer peer + res `shouldBe` BC.pack "public_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=192.168.1.1:1337\npersistant_keepalive_interval=0\nrx_bytes=777\ntx_bytes=778\nlast_handshake_time=1502895867\nallowed_ip=192.168.1.0/24\nallowed_ip=192.168.2.0/24\n" + where + testDevice = do + pkH <- unhex $ BC.pack "e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a" + pshH <- unhex $ BC.pack "188515093e952f5f22e865cef3012e72f8b5f0b598ac0309d5dacce3b70fcf52" + return $ getTestDevice pkH pshH + chkCorrectEnd bs = shouldSatisfy bs (BSL.isSuffixOf (BCL.pack "\n\n") ) +getGenericPeer :: BS.ByteString -> STM Peer +getGenericPeer pub = do + peer <- createPeer pubKey + writeTVar (endPoint peer) $ Just $ SockAddrInet 1337 $ tupleToHostAddress (192,168,1,1) + writeTVar (receivedBytes peer) 777 + writeTVar (transferredBytes peer) 778 + writeTVar (lastHandshakeTime peer) (Just 1502895867) + return peer + where + pubKey = fromJust . DH.dhBytesToPub $ BA.convert pub -getCommand :: BS.ByteString -getCommand = BC.pack "get=1\n\n" +getTestPeerOneRange :: BS.ByteString -> STM Peer +getTestPeerOneRange publicKeyHexBytes = do + p <- getGenericPeer publicKeyHexBytes + writeTVar (ipmasks p) ipmask + return p + where + ipmask = [IPv4Range (read "192.168.1.0/24" :: AddrRange IPv4)] -deviceS :: STM Device -deviceS = createDevice "wg0" +getTestPeerTwoRanges :: BS.ByteString -> STM Peer +getTestPeerTwoRanges publicKeyHexBytes = do + peer <- getGenericPeer publicKeyHexBytes + writeTVar (ipmasks peer) ipmask + return peer + where + ipmask = [IPv4Range (read "192.168.1.0/24" :: AddrRange IPv4), IPv4Range (read "192.168.2.0/24" :: AddrRange IPv4)] -bsDeviceStrict :: BS.ByteString -bsDeviceStrict = BC.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\npreshared_key=188515093e952f5f22e865cef3012e72f8b5f0b598ac0309d5dacce3b70fcf52\nallowed_ip=192.168.4.4/32\nendpoint=[abcd:23::33%2]:51820\n\n" +getTestDevice :: BS.ByteString -> BS.ByteString -> STM Device +getTestDevice pkHex pshHex = do + dev <- createDevice "wg0" + let keyPair = DH.dhBytesToPair $ BA.convert pkHex + let psh = Just $ BA.convert pshHex :: Maybe PresharedKey + writeTVar (localKey dev) keyPair + writeTVar (presharedKey dev) psh + writeTVar (port dev) 12912 + return dev -bsDevice :: BSL.ByteString -bsDevice = BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\npreshared_key=188515093e952f5f22e865cef3012e72f8b5f0b598ac0309d5dacce3b70fcf52\nallowed_ip=192.168.4.4/32\nendpoint=[abcd:23::33%2]:51820\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\npersistent_keepalive_interval=111\nendpoint=182.122.22.19:3233\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\ntx_bytes=1212111\nrx_bytes=1929999999\nerrno=0\n\n" +bsTestDevice :: BSL.ByteString +bsTestDevice = BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=0\n\n" + + +--bsTestDeviceWithPairs :: BSL.ByteString +--bsTestDeviceWithPairs = BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\npreshared_key=188515093e952f5f22e865cef3012e72f8b5f0b598ac0309d5dacce3b70fcf52\nallowed_ip=192.168.4.4/32\nendpoint=[abcd:23::33%2]:51820\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\npersistent_keepalive_interval=111\nendpoint=182.122.22.19:3233\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\ntx_bytes=1212111\nrx_bytes=1929999999\nerrno=0\n\n" -spec :: Spec -spec = describe "serveConduit" $ - it "must respond to a get v1 request" $ do - device <- atomically deviceS - res <- runConduit (yield getCommand .| serveConduit device .| sinkLbs) - res `shouldNotBe` BCL.pack "" |