aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorBaylac-Jacqué Félix <felix@alternativebit.fr>2017-08-11 17:45:01 +0200
committerBaylac-Jacqué Félix <felix@alternativebit.fr>2017-09-16 17:09:43 +0200
commit4f0717969973a799d4d9772042bfbe663fa42f2f (patch)
tree426d73485981a5c44af9e543c4979428a7c39c16
parentMake imports in RPC.hs explicit. (diff)
downloadwireguard-hs-4f0717969973a799d4d9772042bfbe663fa42f2f.tar.xz
wireguard-hs-4f0717969973a799d4d9772042bfbe663fa42f2f.zip
Implement and test RPC show Peer feature.
-rw-r--r--nara.cabal6
-rw-r--r--src/Network/WireGuard/RPC.hs159
-rw-r--r--tests/spec/Network/WireGuard/RPCSpec.hs106
3 files changed, 185 insertions, 86 deletions
diff --git a/nara.cabal b/nara.cabal
index 3f07cd5..f64cad4 100644
--- a/nara.cabal
+++ b/nara.cabal
@@ -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 ""