Initial commit

4 files changed, 203 insertions, 0 deletions

diff --git a/contrib/external-tests/haskell/Setup.hs b/contrib/external-tests/haskell/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/contrib/external-tests/haskell/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/contrib/external-tests/haskell/cacophony-wg.cabal b/contrib/external-tests/haskell/cacophony-wg.cabal
new file mode 100644
index 0000000..62e2485
--- /dev/null
+++ b/contrib/external-tests/haskell/cacophony-wg.cabal
@@ -0,0 +1,34 @@
+-- Initial cacophony-wg.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                cacophony-wg
+version:             0.1.0
+-- synopsis:            
+-- description:         
+license:             PublicDomain
+license-file:        LICENSE
+author:              John Galt
+maintainer:          centromere@users.noreply.github.com
+-- copyright:           
+-- category:            
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+executable cacophony-wg
+  main-is:             Main.hs
+  other-modules:
+    Data.Time.TAI64
+  build-depends:
+    base >=4.8 && <4.9,
+    base16-bytestring,
+    base64-bytestring,
+    blake2,
+    bytestring,
+    cacophony,
+    cereal,
+    cryptonite,
+    network,
+    time
+  hs-source-dirs:      src
+  default-language:    Haskell2010
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