aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--nara.cabal4
-rw-r--r--src/Network/WireGuard/Core.hs8
-rw-r--r--src/Network/WireGuard/Foreign/Tun.hs4
-rw-r--r--src/Network/WireGuard/Internal/Data/RpcTypes.hs2
-rw-r--r--src/Network/WireGuard/Internal/Noise.hs2
-rw-r--r--src/Network/WireGuard/Internal/RpcParsers.hs10
-rw-r--r--src/Network/WireGuard/Internal/Util.hs7
-rw-r--r--src/Network/WireGuard/TunListener.hs2
-rw-r--r--tests/spec/Network/WireGuard/RPCSpec.hs14
9 files changed, 26 insertions, 27 deletions
diff --git a/nara.cabal b/nara.cabal
index aea1387..450dab4 100644
--- a/nara.cabal
+++ b/nara.cabal
@@ -99,7 +99,7 @@ library
buildable: False
ghc-options:
- -Wall -O2
+ -Wall -Werror -O2
if flag(static)
ghc-options:
-optl-static
@@ -116,7 +116,7 @@ test-suite nara-test
main-is: Spec.hs
hs-source-dirs:
tests/spec
- ghc-options: -Wall
+ ghc-options: -Wall -Werror
build-depends:
attoparsec
, base == 4.9.*
diff --git a/src/Network/WireGuard/Core.hs b/src/Network/WireGuard/Core.hs
index 5bbf317..39beb78 100644
--- a/src/Network/WireGuard/Core.hs
+++ b/src/Network/WireGuard/Core.hs
@@ -28,7 +28,7 @@ import Data.Serialize (putWord32be,
runPut)
import Foreign.C.Types (CTime (..))
import Network.Socket (SockAddr)
-import System.IO (hPutStrLn, stderr)
+import System.IO (hPrint, stderr)
import System.Posix.Time (epochTime)
import System.Random (randomIO)
@@ -73,7 +73,7 @@ handleReadTun device readTunChan writeUdpChan = forever $ do
res <- runExceptT $ processTunPacket device writeUdpChan tunPacket
case res of
Right udpPacket -> pushPacketQueue writeUdpChan udpPacket
- Left err -> hPutStrLn stderr (show err) -- TODO: proper logging
+ Left err -> hPrint stderr err -- TODO: proper logging
handleReadUdp :: Device -> PacketQueue UdpPacket -> PacketQueue TunPacket
-> PacketQueue UdpPacket
@@ -82,7 +82,7 @@ handleReadUdp device readUdpChan writeTunChan writeUdpChan = forever $ do
udpPacket <- popPacketQueue readUdpChan
res <- runExceptT $ processUdpPacket device udpPacket
case res of
- Left err -> hPutStrLn stderr (show err) -- TODO: proper logging
+ Left err -> hPrint stderr err -- TODO: proper logging
Right mpacket -> case mpacket of
Just (Right tunp) -> pushPacketQueue writeTunChan tunp
Just (Left udpp) -> pushPacketQueue writeUdpChan udpp
@@ -225,7 +225,7 @@ processPacket device@Device{..} _key _psk sock PacketData{..} = do
unless (remotePub peer `dhPubEq` remotePub peer') $ throwE SourceAddrBlockedError
liftIO $ atomically $ writeTVar (lastReceiveTime peer) now
liftIO $ atomically $ modifyTVar' (receivedBytes peer) (+fromIntegral (BA.length decryptedPayload))
- else do
+ else
liftIO $ atomically $ writeTVar (lastKeepaliveTime peer) now
return (Just (Right decryptedPayload))
diff --git a/src/Network/WireGuard/Foreign/Tun.hs b/src/Network/WireGuard/Foreign/Tun.hs
index 3fdbbd4..89f4bae 100644
--- a/src/Network/WireGuard/Foreign/Tun.hs
+++ b/src/Network/WireGuard/Foreign/Tun.hs
@@ -27,14 +27,14 @@ openTun intfName threads =
tunReadBuf :: Fd -> Ptr Word8 -> CSize -> IO CSize
tunReadBuf _fd _buf 0 = return 0
tunReadBuf fd buf nbytes =
- fmap fromIntegral $
+ fromIntegral <$>
throwErrnoIfMinus1RetryMayBlock "tunReadBuf"
(tun_read_c (fromIntegral fd) (castPtr buf) nbytes)
(threadWaitRead fd)
tunWriteBuf :: Fd -> Ptr Word8 -> CSize -> IO CSize
tunWriteBuf fd buf len =
- fmap fromIntegral $
+ fromIntegral <$>
throwErrnoIfMinus1RetryMayBlock "tunWriteBuf"
(tun_write_c (fromIntegral fd) (castPtr buf) len)
(threadWaitWrite fd)
diff --git a/src/Network/WireGuard/Internal/Data/RpcTypes.hs b/src/Network/WireGuard/Internal/Data/RpcTypes.hs
index 088bbb5..7e1c20e 100644
--- a/src/Network/WireGuard/Internal/Data/RpcTypes.hs
+++ b/src/Network/WireGuard/Internal/Data/RpcTypes.hs
@@ -44,7 +44,7 @@ data RpcDevicePayload = RpcDevicePayload {
instance Show RpcDevicePayload where
show (RpcDevicePayload kp lp fwM rpp) = show (showKeyPair <$> kp) ++ show lp ++ show fwM ++ show rpp
where
- showKeyPair (pk, _) = show $ dhSecToBytes pk
+ showKeyPair (pr, _) = show $ dhSecToBytes pr
instance Eq RpcDevicePayload where
(==) (RpcDevicePayload pk1 prt1 fw1 rp1) (RpcDevicePayload pk2 prt2 fw2 rp2) =
diff --git a/src/Network/WireGuard/Internal/Noise.hs b/src/Network/WireGuard/Internal/Noise.hs
index 4084f42..bd85c05 100644
--- a/src/Network/WireGuard/Internal/Noise.hs
+++ b/src/Network/WireGuard/Internal/Noise.hs
@@ -46,7 +46,7 @@ newNoiseState staticKey presharedKey ephemeralKey remotePub role =
sendFirstMessage :: NoiseStateWG -> ScrubbedBytes
-> Either SomeException (ByteString, NoiseStateWG)
-sendFirstMessage state0 plaintext1 = writeMessage state0 plaintext1
+sendFirstMessage = writeMessage
recvFirstMessageAndReply :: NoiseStateWG -> ByteString -> ScrubbedBytes
-> Either SomeException (ByteString, ScrubbedBytes, PublicKey, SessionKey)
diff --git a/src/Network/WireGuard/Internal/RpcParsers.hs b/src/Network/WireGuard/Internal/RpcParsers.hs
index d2eac92..654cf4e 100644
--- a/src/Network/WireGuard/Internal/RpcParsers.hs
+++ b/src/Network/WireGuard/Internal/RpcParsers.hs
@@ -57,11 +57,11 @@ setPayloadParser = do
deviceParser :: Parser RpcDevicePayload
deviceParser = do
fields <- deviceFieldsParser
- let pk = join $ listToMaybe [ pkF | RpcPk pkF <- fields]
+ 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 pk p fw rmDev
+ return $ RpcDevicePayload devPk p fw rmDev
deviceFieldsParser :: Parser [RpcDeviceField]
deviceFieldsParser = many' (deviceFieldParser <* endOfLine)
@@ -87,8 +87,8 @@ deviceFieldParser = do
peerParser :: Parser RpcPeerPayload
peerParser = do
- pubK <- parsePubKey
- fields <- peerFieldsParser
+ 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]
@@ -98,7 +98,7 @@ peerParser = do
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
+ return $ RpcPeerPayload peerPubK rm psh endP ka rmIps allIpR
where
parsePubKey = do
_ <- "public_key=" <?> "Peer delimiter"
diff --git a/src/Network/WireGuard/Internal/Util.hs b/src/Network/WireGuard/Internal/Util.hs
index 6aefee7..fa48d24 100644
--- a/src/Network/WireGuard/Internal/Util.hs
+++ b/src/Network/WireGuard/Internal/Util.hs
@@ -18,6 +18,7 @@ import Control.Exception (Exception (..),
SomeAsyncException,
SomeException, throwIO)
import Control.Monad.Catch (MonadCatch (..))
+import Data.Foldable (forM_)
import System.IO (hPutStrLn, stderr)
import Foreign
@@ -49,9 +50,7 @@ catchSomeExceptionAnd what m = catch m $ \(_ :: SomeException) -> what
withJust :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
withJust mma func = do
ma <- mma
- case ma of
- Nothing -> return ()
- Just a -> func a
+ forM_ ma func
dropUntilM :: Monad m => (a -> Bool) -> m a -> m a
dropUntilM cond ma = loop
@@ -66,7 +65,7 @@ zeroMemory :: Ptr a -> CSize -> IO ()
zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes)
copyMemory :: Ptr a -> Ptr b -> CSize -> IO ()
-copyMemory dest src nbytes = memcpy dest src nbytes
+copyMemory = memcpy
foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()
foreign import ccall unsafe "string.h" memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
diff --git a/src/Network/WireGuard/TunListener.hs b/src/Network/WireGuard/TunListener.hs
index 34b961b..7e4cfcb 100644
--- a/src/Network/WireGuard/TunListener.hs
+++ b/src/Network/WireGuard/TunListener.hs
@@ -41,5 +41,5 @@ readTun buf fd = do
(\ptr -> copyMemory ptr buf nbytes >> zeroMemory buf nbytes)
writeTun :: BA.ByteArrayAccess ba => Fd -> ba -> IO ()
-writeTun fd ba = BA.withByteArray ba $ \ptr -> do
+writeTun fd ba = BA.withByteArray ba $ \ptr ->
void $ tunWriteBuf fd ptr (fromIntegral (BA.length ba))
diff --git a/tests/spec/Network/WireGuard/RPCSpec.hs b/tests/spec/Network/WireGuard/RPCSpec.hs
index a69a9b5..ccd52d5 100644
--- a/tests/spec/Network/WireGuard/RPCSpec.hs
+++ b/tests/spec/Network/WireGuard/RPCSpec.hs
@@ -60,7 +60,7 @@ spec = do
peer2 <- atomically $ getPeer2 pubKey2
peer3 <- atomically $ getPeer3 pubKey3
let devStm = testDeviceWithPeers [(BC.pack "peer1", peer1), (BC.pack "peer2", peer2), (BC.pack "peer3", peer3)]
- device <- atomically $ devStm
+ device <- atomically devStm
res <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit device .| sinkLbs)
res `shouldBe` bsTestDeviceWithPairs
chkCorrectEnd res
@@ -78,8 +78,8 @@ spec = do
dev <- atomically devStm
err <- runConduit (yield (BC.pack "set=1\nprivate_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\nendpoint=[abcd:23::33%2]:51820\nallowed_ip=192.168.4.4/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\nallowed_ip=192.168.4.6/32\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\n\n") .| serveConduit dev .| sinkLbs)
err `shouldBe` BCL.pack "errno=0\n\n"
- dev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
- dev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\nendpoint=[abcd:23::33%2]:51820\nallowed_ip=192.168.4.4/32\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\nallowed_ip=192.168.4.6/32\nerrno=0\n\n"
+ resDev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
+ resDev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\nendpoint=[abcd:23::33%2]:51820\nallowed_ip=192.168.4.4/32\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\nallowed_ip=192.168.4.6/32\nerrno=0\n\n"
it "must repond to a correctly formed set device's peers V1 request with one peer remove instruction" $ do
pk <- unhex $ BC.pack "e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a"
pubKey1 <- unhex $ BC.pack "b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33"
@@ -92,8 +92,8 @@ spec = do
dev <- atomically devStm
err <- runConduit (yield (BC.pack "set=1\nprivate_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\nremove=true\nendpoint=[abcd:23::33%2]:51820\nallowed_ip=192.168.4.4/32\n\n") .| serveConduit dev .| sinkLbs)
err `shouldBe` BCL.pack "errno=0\n\n"
- dev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
- dev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\ntx_bytes=1212111\nrx_bytes=1929999999\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\nerrno=0\n\n"
+ resDev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
+ resDev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\ntx_bytes=1212111\nrx_bytes=1929999999\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\nerrno=0\n\n"
it "must repond to a correctly formed set device's peers V1 request with one peer alter instruction" $ do
pk <- unhex $ BC.pack "e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a"
pubKey1 <- unhex $ BC.pack "b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33"
@@ -106,8 +106,8 @@ spec = do
dev <- atomically devStm
err <- runConduit (yield (BC.pack "set=1\nprivate_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\npublic_key=b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33\nremove=true\nendpoint=[abcd:23::33%2]:51820\nallowed_ip=192.168.4.4/32\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\nallowed_ip=192.168.5.6/32\n\n") .| serveConduit dev .| sinkLbs)
err `shouldBe` BCL.pack "errno=0\n\n"
- dev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
- dev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\ntx_bytes=1212111\nrx_bytes=1929999999\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\nallowed_ip=192.168.5.6/32\nerrno=0\n\n"
+ resDev <- runConduit (yield (BC.pack "get=1\n\n") .| serveConduit dev .| sinkLbs)
+ resDev `shouldBe` BCL.pack "private_key=e84b5a6d2717c1003a13b431570353dbaca9146cf150c5f8575680feba52027a\nlisten_port=12912\nfwmark=1\npublic_key=662e14fd594556f522604703340351258903b64f35553763f19426ab2a515c58\nendpoint=5.152.198.39:51820\ntx_bytes=1212111\nrx_bytes=1929999999\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\nallowed_ip=192.168.4.10/32\nallowed_ip=192.168.4.11/32\npublic_key=58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376\nendpoint=182.122.22.19:3233\npersistent_keepalive_interval=111\ntx_bytes=38333\nrx_bytes=2224\nallowed_ip=192.168.4.6/32\nallowed_ip=192.168.5.6/32\nerrno=0\n\n"
it "must repond to a correctly formed delete device's peers set V1 request" $ do
pubKey1 <- unhex $ BC.pack "b85996fecc9c7f1fc6d2572a76eda11d59bcd20be8e543b15ce4bd85a8e75a33"
pubKey2 <- unhex $ BC.pack "58402e695ba1772b1cc9309755f043251ea77fdcf10fbe63989ceb7e19321376"
Copyright © 1996 – 2023 Jason A. Donenfeld. All Rights Reverse Engineered.