diff options
Diffstat (limited to 'contrib/external-tests/haskell/src')
-rw-r--r-- | contrib/external-tests/haskell/src/Data/Time/TAI64.hs | 86 | ||||
-rw-r--r-- | contrib/external-tests/haskell/src/Main.hs | 81 |
2 files changed, 167 insertions, 0 deletions
diff --git a/contrib/external-tests/haskell/src/Data/Time/TAI64.hs b/contrib/external-tests/haskell/src/Data/Time/TAI64.hs new file mode 100644 index 0000000..37a90e6 --- /dev/null +++ b/contrib/external-tests/haskell/src/Data/Time/TAI64.hs @@ -0,0 +1,86 @@ +module Data.Time.TAI64 ( + TAI64(..) + , TAI64N(..) + , TAI64NA(..) + , posixToTAI64 + , posixToTAI64N + , posixToTAI64NA + , getCurrentTAI64 + , getCurrentTAI64N + , getCurrentTAI64NA + , tAI64ToPosix + , tAI64NToPosix + , tAI64NAToPosix +) where + +import Data.Serialize +import Control.Monad +import Data.Word + +import Data.Time.Clock +import Data.Time.Clock.POSIX + +import Numeric + +data TAI64 = TAI64 + {-# UNPACK #-} !Word64 + deriving (Eq, Ord) + +data TAI64N = TAI64N + {-# UNPACK #-} !TAI64 + {-# UNPACK #-} !Word32 + deriving (Eq, Ord, Show) + +data TAI64NA = TAI64NA + {-# UNPACK #-} !TAI64N + {-# UNPACK #-} !Word32 + deriving (Eq, Ord, Show) + +instance Show TAI64 where + show (TAI64 t) = "TAI64 0x" ++ showHex t "" + +instance Serialize TAI64 where + put (TAI64 t) = putWord64be t + get = liftM TAI64 get + +instance Serialize TAI64N where + put (TAI64N t' nt) = put t' >> putWord32be nt + get = liftM2 TAI64N get get + +instance Serialize TAI64NA where + put (TAI64NA t' at) = put t' >> putWord32be at + get = liftM2 TAI64NA get get + + +posixToTAI64 :: POSIXTime -> TAI64 +posixToTAI64 = TAI64 . (2^62 +) . truncate . realToFrac + +posixToTAI64N :: POSIXTime -> TAI64N +posixToTAI64N pt = TAI64N t' ns where + t' = posixToTAI64 pt + ns = (`mod` 10^9) $ truncate (pts * 10**9) + pts = realToFrac pt + +posixToTAI64NA :: POSIXTime -> TAI64NA -- | PICOsecond precision +posixToTAI64NA pt = TAI64NA t' as where + t' = posixToTAI64N pt + as = (`mod` 10^9) $ truncate (pts * 10**18) + pts = realToFrac pt + +getCurrentTAI64 :: IO TAI64 +getCurrentTAI64N :: IO TAI64N +getCurrentTAI64NA :: IO TAI64NA +getCurrentTAI64 = liftM posixToTAI64 getPOSIXTime +getCurrentTAI64N = liftM posixToTAI64N getPOSIXTime +getCurrentTAI64NA = liftM posixToTAI64NA getPOSIXTime + +tAI64ToPosix :: TAI64 -> POSIXTime +tAI64ToPosix (TAI64 s) = fromRational . fromIntegral $ s - 2^62 + +tAI64NToPosix :: TAI64N -> POSIXTime +tAI64NToPosix (TAI64N t' n) = tAI64ToPosix t' + nanopart where + nanopart = fromRational $ (toRational $ 10**(-9)) * toRational n -- TODO: optimize? + +tAI64NAToPosix :: TAI64NA -> POSIXTime +tAI64NAToPosix (TAI64NA t' a) = tAI64NToPosix t' + attopart where + attopart = fromRational $ (toRational $ 10**(-18)) * toRational a diff --git a/contrib/external-tests/haskell/src/Main.hs b/contrib/external-tests/haskell/src/Main.hs new file mode 100644 index 0000000..f78305d --- /dev/null +++ b/contrib/external-tests/haskell/src/Main.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar +import Control.Monad (void) +import Data.ByteString.Char8 (pack, unpack, take, drop, replicate) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Hex +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Serialize as S +import Prelude hiding (take, drop, replicate) +import System.Environment +import Network.Socket +import qualified Network.Socket.ByteString as NBS + +import Crypto.Hash.BLAKE2.BLAKE2s +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Handshake +import Crypto.Noise.HandshakePatterns +import Crypto.Noise.Hash.BLAKE2s +import Crypto.Noise.Types + +import Data.Time.TAI64 + +w :: PublicKey Curve25519 + -> Plaintext + -> Socket + -> SockAddr + -> ByteString + -> IO () +w theirPub (Plaintext myPSK) sock addr msg = do + let x = "\x01\x00\x00" `mappend` msg + mac = hash 16 myPSK (sbToBS' (curvePubToBytes theirPub) `mappend` sbToBS' x) + void $ NBS.sendTo sock (x `mappend` mac `mappend` replicate 16 '\0') addr + +r :: MVar ByteString -> Socket -> IO ByteString +r smv sock = do + (r, _) <- NBS.recvFrom sock 1024 + putMVar smv $ (take 2 . drop 1) r + return . take 48 . drop 5 $ r + +payload :: IO Plaintext +payload = do + tai64n <- getCurrentTAI64N + return . Plaintext . bsToSB' $ S.encode tai64n + +main :: IO () +main = do + let ip = "test.wireguard.io" + let port = "51820" + let mykey = "WAmgVYXkbT2bCtdcDwolI88/iVi/aV3/PHcUBTQSYmo=" + let serverkey = "qRCwZSKInrMAq5sepfCdaCsRJaoLe5jhtzfiw7CjbwM=" + let psk = "FpCyhws9cxwWoV4xELtfJvjJN+zQVRPISllRWgeopVE=" + addrInfo <- head <$> getAddrInfo Nothing (Just ip) (Just port) + sock <- socket (addrFamily addrInfo) Datagram defaultProtocol + + let addr = addrAddress addrInfo + mykey' = curveBytesToPair . bsToSB' . either undefined id . B64.decode . pack $ mykey :: KeyPair Curve25519 + serverkey' = curveBytesToPub . bsToSB' . either undefined id . B64.decode . pack $ serverkey :: PublicKey Curve25519 + psk' = Plaintext . bsToSB' . either undefined id . B64.decode . pack $ psk + hs = handshakeState $ HandshakeStateParams + noiseIK + "WireGuard v0 zx2c4 Jason@zx2c4.com" + (Just psk') + (Just mykey') + Nothing + (Just serverkey') + Nothing + True :: HandshakeState ChaChaPoly1305 Curve25519 BLAKE2s + + senderindexmv <- newEmptyMVar + let hc = HandshakeCallbacks (w serverkey' psk' sock addr) (r senderindexmv sock) (\_ -> return ()) payload + (encryption, decryption) <- runHandshake hs hc + + let (keepAlive, encryption') = encryptPayload "" encryption + senderindex <- takeMVar senderindexmv + void $ NBS.sendTo sock ("\x04" `mappend` senderindex `mappend` replicate 8 '\0' `mappend` keepAlive) addr |