haskell: re-add updated haskell example

Code-from: John Galt <jgalt@centromere.net>
Signed-off-by: Jason A. Donenfeld <Jason@zx2c4.com>

contrib/external-tests/haskell/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

contrib/external-tests/haskell/package.yaml

@@ -0,0 +1,36 @@
+name: cacophony-wg
+version: 0.1.0
+license: PublicDomain
+maintainer: John Galt <jgalt@centromere.net>
+category: Cryptography
+ghc-options: -Wall
+
+executables:
+  cacophony-wg:
+    main: Main.hs
+    source-dirs: src
+
+    dependencies:
+      - base
+      - base16-bytestring
+      - base64-bytestring
+      - blake2
+      - bytestring
+      - cacophony >= 0.10
+      - cereal
+      - cryptonite
+      - memory
+      - network
+      - time
+
+    ghc-options:
+      - -O2
+      - -rtsopts
+      - -threaded
+      - -with-rtsopts=-N
+
+    other-modules:
+      - Data.Time.TAI64
+
+    default-extensions:
+      - OverloadedStrings

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

contrib/external-tests/haskell/src/Main.hs

@@ -0,0 +1,138 @@
+module Main where
+
+import           Control.Monad              (void)
+import           Crypto.Hash.BLAKE2.BLAKE2s (hash)
+import           Data.ByteArray             (ScrubbedBytes, convert)
+import           Data.ByteString            (ByteString, replicate, take, drop)
+import qualified Data.ByteString.Base16     as B16
+import qualified Data.ByteString.Base64     as B64
+import           Data.Maybe                 (fromMaybe)
+import           Data.Monoid                ((<>))
+import qualified Data.Serialize             as S
+import           Network.Socket
+import qualified Network.Socket.ByteString  as NBS
+import           Prelude hiding             (replicate, take, drop)
+
+import Crypto.Noise
+import Crypto.Noise.Cipher
+import Crypto.Noise.Cipher.ChaChaPoly1305
+import Crypto.Noise.DH
+import Crypto.Noise.DH.Curve25519
+import Crypto.Noise.HandshakePatterns (noiseIKpsk2)
+import Crypto.Noise.Hash hiding (hash)
+import Crypto.Noise.Hash.BLAKE2s
+
+import Data.Time.TAI64
+
+sampleICMPRequest :: ByteString
+sampleICMPRequest = fst . B16.decode $
+  "450000250000000014018f5b0abd81020abd810108001bfa039901b6576972654775617264"
+
+validateICMPResponse :: ByteString
+                     -> Bool
+validateICMPResponse r =
+  -- Strip off part of IPv4 header because this is only a demo.
+  drop 12 sample == drop 12 r
+  where
+    sample = fst . B16.decode $ "45000025e3030000400180570abd81010abd8102000023fa039901b65769726547756172640000000000000000000000"
+
+unsafeMessage :: (Cipher c, DH d, Hash h)
+              => Bool
+              -> Maybe ScrubbedBytes
+              -> ScrubbedBytes
+              -> NoiseState c d h
+              -> (ScrubbedBytes, NoiseState c d h)
+unsafeMessage write mpsk msg ns = case operation msg ns of
+  NoiseResultMessage ct ns' -> (ct, ns')
+
+  NoiseResultNeedPSK ns' -> case mpsk of
+    Nothing -> error "psk required but not provided"
+    Just k  -> case operation k ns' of
+      NoiseResultMessage ct ns'' -> (ct, ns'')
+      _ -> error "something terrible happened"
+
+  _ -> error "something terrible happened"
+  where
+    operation = if write then writeMessage else readMessage
+
+main :: IO ()
+main = do
+  let ip           = "demo.wireguard.io"
+      port         = "12913"
+      myKeyB64     = "WAmgVYXkbT2bCtdcDwolI88/iVi/aV3/PHcUBTQSYmo=" -- private key
+      serverKeyB64 = "qRCwZSKInrMAq5sepfCdaCsRJaoLe5jhtzfiw7CjbwM=" -- public key
+      pskB64       = "FpCyhws9cxwWoV4xELtfJvjJN+zQVRPISllRWgeopVE="
+
+  addrInfo <- head <$> getAddrInfo Nothing (Just ip) (Just port)
+  sock     <- socket (addrFamily addrInfo) Datagram defaultProtocol
+
+  let addr        = addrAddress addrInfo
+      myStaticKey = fromMaybe (error "invalid private key")
+                    . dhBytesToPair
+                    . convert
+                    . either (error "error Base64 decoding my private key") id
+                    . B64.decode
+                    $ myKeyB64 :: KeyPair Curve25519
+
+      serverKey   = fromMaybe (error "invalid public key")
+                    . dhBytesToPub
+                    . convert
+                    . either (error "error Base64 decoding server public key") id
+                    . B64.decode
+                    $ serverKeyB64 :: PublicKey Curve25519
+
+      psk         = convert
+                    . either (error "error decoding PSK") id
+                    . B64.decode
+                    $ pskB64 :: ScrubbedBytes
+
+  myEphemeralKey <- dhGenKey
+
+  let dho  = defaultHandshakeOpts InitiatorRole "WireGuard v1 zx2c4 Jason@zx2c4.com"
+      opts = setLocalEphemeral (Just myEphemeralKey)
+             . setLocalStatic  (Just myStaticKey)
+             . setRemoteStatic (Just serverKey)
+             $ dho
+      ns0  = noiseState opts noiseIKpsk2 :: NoiseState ChaChaPoly1305 Curve25519 BLAKE2s
+
+  tai64n <- convert . S.encode <$> getCurrentTAI64N
+
+  -- Handshake: Initiator to responder -----------------------------------------
+
+  let (msg0, ns1) = unsafeMessage True Nothing tai64n ns0
+      macKey      = hash 32 mempty $ "mac1----" `mappend` (convert . dhPubToBytes) serverKey
+      initiation  = "\x01\x00\x00\x00\x1c\x00\x00\x00" <> convert msg0 -- sender index = 28 to match other examples
+      mac1        = hash 16 macKey initiation
+
+  void $ NBS.sendTo sock (initiation <> mac1 <> replicate 16 0) addr
+
+  -- Handshake: Responder to initiator -----------------------------------------
+
+  (response0, _) <- NBS.recvFrom sock 1024
+
+  let theirIndex  = take 4  . drop 4  $ response0
+      (_, ns2)    = unsafeMessage False (Just psk) (convert . take 48 . drop 12 $ response0) ns1
+
+  -- ICMP: Initiator to responder ----------------------------------------------
+
+  let (msg1, ns3) = unsafeMessage True Nothing (convert sampleICMPRequest) ns2
+      icmp        = "\x04\x00\x00\x00" <> theirIndex <> replicate 8 0 <> convert msg1
+
+  void $ NBS.sendTo sock icmp addr
+
+  -- ICMP: Responder to initiator ----------------------------------------------
+
+  (response1, _) <- NBS.recvFrom sock 1024
+
+  let (icmpPayload, ns4) = unsafeMessage False Nothing (convert . drop 16 $ response1) ns3
+
+  -- KeepAlive: Initiator to responder -----------------------------------------
+
+  if validateICMPResponse . convert $ icmpPayload
+    then do
+      let (msg2, _) = unsafeMessage True Nothing mempty ns4
+          keepAlive = "\x04\x00\x00\x00" <> theirIndex <> "\x01" <> replicate 7 0 <> convert msg2
+
+      void $ NBS.sendTo sock keepAlive addr
+
+    else error "unexpected ICMP response from server!"

contrib/external-tests/haskell/stack.yaml

@@ -0,0 +1,6 @@
+resolver: lts-8.18
+packages:
+  - '.'
+extra-deps: []
+flags: {}
+extra-package-dbs: []