From e7fd4cfd3f98e9709842f6a33695e0ee7b79fbd0 Mon Sep 17 00:00:00 2001 From: "Jason A. Donenfeld" Date: Tue, 13 Jun 2017 23:35:27 +0200 Subject: [PATCH] haskell: re-add updated haskell example Code-from: John Galt Signed-off-by: Jason A. Donenfeld --- contrib/external-tests/haskell/Setup.hs | 2 + contrib/external-tests/haskell/package.yaml | 36 +++++ .../haskell/src/Data/Time/TAI64.hs | 86 +++++++++++ contrib/external-tests/haskell/src/Main.hs | 138 ++++++++++++++++++ contrib/external-tests/haskell/stack.yaml | 6 + 5 files changed, 268 insertions(+) create mode 100644 contrib/external-tests/haskell/Setup.hs create mode 100644 contrib/external-tests/haskell/package.yaml create mode 100644 contrib/external-tests/haskell/src/Data/Time/TAI64.hs create mode 100644 contrib/external-tests/haskell/src/Main.hs create mode 100644 contrib/external-tests/haskell/stack.yaml 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/package.yaml b/contrib/external-tests/haskell/package.yaml new file mode 100644 index 0000000..3c8cc55 --- /dev/null +++ b/contrib/external-tests/haskell/package.yaml @@ -0,0 +1,36 @@ +name: cacophony-wg +version: 0.1.0 +license: PublicDomain +maintainer: John Galt +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 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..b0b7503 --- /dev/null +++ b/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!" diff --git a/contrib/external-tests/haskell/stack.yaml b/contrib/external-tests/haskell/stack.yaml new file mode 100644 index 0000000..f5612fc --- /dev/null +++ b/contrib/external-tests/haskell/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-8.18 +packages: + - '.' +extra-deps: [] +flags: {} +extra-package-dbs: []