Compare commits
2 Commits
e0b8820418
...
7a65433872
Author | SHA1 | Date | |
---|---|---|---|
Jonathan Lamothe | 7a65433872 | ||
Jonathan Lamothe | fa8ef1104a |
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 2.2
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
|
@ -34,7 +34,7 @@ library
|
|||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, bytestring >=0.10.12.0 && <0.11
|
||||
, bytestring >=0.11.3.1 && <0.12
|
||||
, io-streams
|
||||
, network
|
||||
, tcp-streams >=1.0.1.1 && <1.1
|
||||
|
@ -58,9 +58,9 @@ test-suite gemcap-test
|
|||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, bytestring >=0.10.12.0 && <0.11
|
||||
, bytestring >=0.11.3.1 && <0.12
|
||||
, gemcap
|
||||
, hspec >=2.7.10 && <2.8
|
||||
, hspec >=2.9.7 && <2.10
|
||||
, io-streams
|
||||
, network
|
||||
, tcp-streams >=1.0.1.1 && <1.1
|
||||
|
|
|
@ -25,7 +25,7 @@ ghc-options:
|
|||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- bytestring >= 0.10.12.0 && < 0.11
|
||||
- bytestring >= 0.11.3.1 && < 0.12
|
||||
- tcp-streams >= 1.0.1.1 && < 1.1
|
||||
- text >= 1.2.4.1 && < 1.3
|
||||
- io-streams
|
||||
|
@ -49,6 +49,6 @@ tests:
|
|||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- gemcap
|
||||
- hspec >= 2.7.10 && < 2.8
|
||||
- hspec >= 2.9.7 && < 2.10
|
||||
verbatim:
|
||||
<<: *paths
|
|
@ -34,12 +34,12 @@ import Control.Concurrent (forkIO)
|
|||
import Control.Exception (IOException, try)
|
||||
import Control.Exception.Base (bracket, finally)
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
||||
import qualified Data.Connection as C
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.TLSSetting (makeServerParams)
|
||||
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
|
||||
import Data.X509 (CertificateChain (..), getSigned, signedObject)
|
||||
import qualified Network.Socket as S
|
||||
import Network.TLS (ServerParams, onClientCertificate, serverHooks)
|
||||
import Network.TLS (ServerParams, getClientCertificateChain)
|
||||
import System.IO.Streams.TCP (bindAndListen)
|
||||
import System.IO.Streams.TLS (accept)
|
||||
|
||||
|
@ -69,32 +69,18 @@ runGemCapsule settings handler = bracket
|
|||
|
||||
listenLoop :: S.Socket -> ServerParams -> GemHandler -> IO a
|
||||
listenLoop sock params handler = do
|
||||
certRef <- newIORef Nothing
|
||||
let params' = adjustServerParams certRef params
|
||||
try (accept params' sock) >>= \case
|
||||
try (accept params sock) >>= \case
|
||||
Left (_::IOException) -> return ()
|
||||
Right conn -> void $ forkIO $ finally
|
||||
(readIORef certRef >>= runConnection conn handler)
|
||||
( do
|
||||
let (context, _) = C.connExtraInfo conn
|
||||
mCert <- runMaybeT $
|
||||
MaybeT (getClientCertificateChain context) >>= \case
|
||||
CertificateChain [] -> fail "no certificate"
|
||||
CertificateChain (se:_) -> return $ signedObject $ getSigned se
|
||||
runConnection conn handler mCert
|
||||
)
|
||||
(C.close conn)
|
||||
listenLoop sock params handler
|
||||
|
||||
adjustServerParams
|
||||
:: IORef (Maybe Certificate)
|
||||
-> ServerParams
|
||||
-> ServerParams
|
||||
adjustServerParams certRef params = let
|
||||
hooks = serverHooks params
|
||||
certHook = onClientCertificate hooks
|
||||
|
||||
certHook' chain = do
|
||||
case chain of
|
||||
CertificateChain [] -> return ()
|
||||
CertificateChain (se:_) -> do
|
||||
let cert = signedObject $ getSigned se
|
||||
writeIORef certRef (Just cert)
|
||||
certHook chain
|
||||
|
||||
hooks' = hooks { onClientCertificate = certHook' }
|
||||
in params { serverHooks = hooks' }
|
||||
|
||||
--jl
|
||||
|
|
|
@ -17,8 +17,7 @@
|
|||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
|
||||
resolver: lts-20.5
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
|
@ -40,8 +39,6 @@ packages:
|
|||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
extra-deps:
|
||||
- tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
|
|
@ -3,18 +3,10 @@
|
|||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
|
||||
pantry-tree:
|
||||
size: 1004
|
||||
sha256: 572071fca40a0b6c4cc950d10277a6f12e83cf4846882b6ef83fcccaa2c18c45
|
||||
original:
|
||||
hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 586268
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
|
||||
sha256: d9e658a22cfe8d87a64fdf219885f942fef5fe2bcb156a9800174911c5da2443
|
||||
original:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
|
||||
sha256: a684cdbdf9304b325a503e0fe1d9648e9c18155ce4c7cfebbe8a7f93674e6295
|
||||
size: 649106
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/5.yaml
|
||||
original: lts-20.5
|
||||
|
|
Loading…
Reference in New Issue
Block a user