#!/usr/bin/envstack{- stack
--resolver lts-11.7
--install-ghc
runghc
--package bytestring
--package network
--package time
--package data-default-class
--package tls
--package x509
--package x509-store
--package x509-validation
--
-}-- -Wall -Werror-- Issue with stack: Version 1.7.1-- Git revision 681c800873816c022739ca7ed14755e85a579565 x86_64 hpack-0.28.2-- the following flags after -- aren't read anymore and are just sent as extra-- arguments which are caught by getArgs. Therefore, they are outcommented--------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------moduleMain(main)where--------------------------------------------------------------------------------importControl.Exception(IOException,try)importqualifiedData.ByteStringasBSimportqualifiedData.ByteString.Lazy.Char8asL8importData.Maybe(fromJust,fromMaybe,listToMaybe)importData.Time(defaultTimeLocale,formatTime,getCurrentTime)importData.Word(Word8)importqualifiedData.X509asX509importData.X509.CertificateStore(readCertificateStore)importqualifiedData.X509.ValidationasX509importData.Default.Class(def)importNetwork.Sockethiding(recv,send)importqualifiedNetwork.TLSasTimportqualifiedNetwork.TLS.ExtraasTEimportSystem.Environment(getArgs)--------------------------------------------------------------------------------tlsPort::IOPortNumberiso8601::IOStringrecv::T.Context->IO(EitherIOExceptionBS.ByteString)send::T.Context->[BS.ByteString]->IO(EitherIOException())ping::T.Context->IO()client::IO()main::IO()--------------------------------------------------------------------------------main=client--------------------------------------------------------------------------------tlsPort=getArgs>>=pure.fromMaybe8443.listToMaybe.(mapread)iso8601=-- https://hackage.haskell.org/package/time-1.9.1/docs/Data-Time-Format.htmlgetCurrentTime>>=pure.(formatTimedefaultTimeLocale"%FT%T%0QZ")recvctx=try$T.recvDatactxsendctxbs=try$T.sendDatactx$L8.fromChunks$bspingctx=doreq<-sendctx["ping"]caseRight()==reqofFalse->T.contextClosectxTrue->dotsping<-iso8601putStrLn$tsping++" | Client | Ping"res<-recvctxcaseRight"pong"==resofFalse->T.contextClosectxTrue->dotspong<-iso8601putStrLn$tspong++" | Server | Pong"pingctxclient=doport<-tlsPortx509<-cacssock<-socketAF_INETStream0____<-connectsock$SockAddrInetport(tupleToHostAddresshost)putStrLn$("Connected to: "++)$namectx<-T.contextNewsock$parax509___<-T.handshakectxpingctxwherecacs=readCertificateStore"../tls/root.ca.crt">>=pure.fromJusthost=(127,0,0,1)::(Word8,Word8,Word8,Word8)name="localhost"::HostNameparax509=(T.defaultParamsClientnameBS.empty){T.clientSupported=def{T.supportedCiphers=TE.ciphersuite_strong,T.supportedVersions=[T.TLS12]},T.clientShared=def{T.sharedCAStore=x509},T.clientHooks=hook}hook=-- Disable checkLeafV3 when testing wit local created CAs-- github.com/vincenthz/hs-tls/issues/154#issuecomment-268083940def{T.onServerCertificate=leaf}leaf=X509.validateX509.HashSHA256X509.defaultHooks$X509.defaultChecks{T.checkLeafV3=False}
#!/usr/bin/envstack{- stack
--resolver lts-11.7
--install-ghc
runghc
--package bytestring
--package network
--package data-default-class
--package tls
--
-}-- -Wall -Werror-- Issue with stack: Version 1.7.1-- Git revision 681c800873816c022739ca7ed14755e85a579565 x86_64 hpack-0.28.2-- the following flags after -- aren't read anymore and are just sent as extra-- arguments which are caught by getArgs. Therefore, they are outcommented--------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------moduleMain(main)where--------------------------------------------------------------------------------importControl.Exception(IOException,try)importControl.Concurrent(forkIO)importqualifiedData.ByteStringasBSimportqualifiedData.ByteString.Lazy.Char8asL8importData.Maybe(fromMaybe,listToMaybe)importData.Default.Class(def)importNetwork.Sockethiding(recv,send)importqualifiedNetwork.TLSasTimportqualifiedNetwork.TLS.ExtraasTEimportSystem.Environment(getArgs)--------------------------------------------------------------------------------tlsPort::IOPortNumberrecv::T.Context->IO(EitherIOExceptionBS.ByteString)send::T.Context->[BS.ByteString]->IO(EitherIOException())pong::T.Context->IO()spawn::(Socket,SockAddr)->T.Credentials->IO()loop::Socket->EitherStringT.Credential->IO()server::IO()main::IO()--------------------------------------------------------------------------------main=server--------------------------------------------------------------------------------tlsPort=getArgs>>=pure.fromMaybe8443.listToMaybe.(mapread)recvctx=try$T.recvDatactxsendctxbs=try$T.sendDatactx$L8.fromChunks$bspongctx=dores<-recvctxcaseRight"ping"==resofFalse->T.contextClosectxTrue->doreq<-sendctx$["pong"]caseRight()==reqofFalse->T.contextClosectxTrue->pongctxspawn(sock,_)creds=doctx<-T.contextNewsock$paracreds___<-T.handshakectxpongctxwhereparax509=def{T.serverWantClientCert=False,T.serverShared=shared,T.serverSupported=supported}whereshared=def{T.sharedCredentials=x509}supported=def{T.supportedVersions=[T.TLS12],T.supportedCiphers=ciphers}ciphers=[TE.cipher_AES128_SHA1,TE.cipher_AES256_SHA1,TE.cipher_RC4_128_MD5,TE.cipher_RC4_128_SHA1]loopsock(Rightcreds)=doconn<-accept$sockputStrLn$("Connected to: "++)$show$snd$conn____<-forkIO$spawnconn$T.Credentials[creds]loopsock$Rightcredsloop____(Leftmsg)=putStrLn$msgserver=doport<-tlsPortx509<-T.credentialLoadX509"../tls/localhost.crt""../tls/localhost.key"sock<-socketAF_INETStream0____<-setSocketOptionsockReuseAddr1____<-bindsock$SockAddrInetportiNADDR_ANY____<-listensock256putStrLn$"Listening on port "++showportloopsockx509
ghc-options:## - GHC 8.2.2 Users Guide > 7. Using GHC > 7.2. Warnings and sanity-checking## * Base: https://downloads.haskell.org/~ghc/8.2.2/docs/html/users_guide/## * File: using-warnings.html#ghc-flag--Wall## Warnings that are not enabled by -Wall:--Wall--Wincomplete-uni-patterns--Wincomplete-record-updates--Wmonomorphism-restriction#- -Wimplicit-prelude--Wmissing-local-signatures--Wmissing-exported-signatures#- -Wmissing-import-lists--Wmissing-home-modules--Widentities--Wredundant-constraints## Allow instances to be created in other files (like in C .h/.c files)--Wno-orphans## Makes any warning into a fatal error.--Werrorexecutables:client:dependencies:## Date and time stamps-time## x509 certificates, storage and validation-x509-x509-store-x509-validationmain:src/Client.hsghc-options:--O2server:main:src/Server.hsghc-options:--O2--threaded--rtsopts--with-rtsopts=-N# The -N flag built-in can be modified on runtime based on the system# hosting the binary for optimal performance:# hackage.haskell.org/package/base-4.11.1.0/docs/GHC-Conc.html# - getNumProcessors# hackage.haskell.org/package/base-4.11.1.0/docs/Control-Concurrent.html# - setNumCapabilities# Stacks LTS resolver will ensure specific packages for deterministic buildsdependencies:-base## Byte strings-bytestring## Netork (sockets)-network## TLS/SSL protocol native implementation (Server and Client)-data-default-class-tls
build.bash
1
2
3
4
5
6
7
8
9
10
11
12
13
#!/bin/bash
clear
# clear previous bin file
find ./bin -name'server'-delete
find ./bin -name'client'-delete# local (static) compilation with stack
stack install--local-bin-path ./bin
# clear .cabal file
find .-name'*.cabal'-delete
many.clients.tls.bash
1
2
3
4
5
6
7
8
9
10
#!/bin/bash
clear
cd bin
for i in$(seq-f"%05g" 1 64);do
echo"Spawned client ID:"$i
./client >"../log/$i.txt" &
done