[DO NOT MERGE] Authenticate Peers and lock down cut db

src/Chainweb/HostAddress.hs

@@ -114,6 +114,9 @@ module Chainweb.HostAddress
 , hostPreferenceToText
 , hostPreferenceFromText
 
+-- * SockAddr from network package
+, sockAddrToHostAddress
+
 -- * Properties
 , properties
 ) where
@@ -139,6 +142,8 @@ import Data.Word (Word16, Word8)
 import GHC.Generics (Generic)
 import GHC.Stack (HasCallStack)
 
+import qualified Network.Socket as N
+
 import Servant.Client (BaseUrl(..), Scheme(..))
 
 import Test.QuickCheck
@@ -599,6 +604,23 @@ instance HasTextRepresentation HostPreference where
     fromText = hostPreferenceFromText
     {-# INLINE fromText #-}
 
+-- -------------------------------------------------------------------------- --
+-- Sock Address
+
+sockAddrToHostAddress :: N.SockAddr -> Maybe HostAddress
+sockAddrToHostAddress (N.SockAddrInet p ha) = Just HostAddress
+    { _hostAddressHost = ha2hn ha
+    , _hostAddressPort = int p
+    }
+sockAddrToHostAddress (N.SockAddrInet6 _p _f _h _s) = Nothing -- TODO
+sockAddrToHostAddress _ = Nothing
+
+ha2hn:: N.HostAddress -> Hostname
+ha2hn ha = HostnameIPv4 $ CI.mk $
+    B8.intercalate "." $ sshow <$> [a0,a1,a2,a3]
+  where
+    (a0,a1,a2,a3) = N.hostAddressToTuple ha
+
 -- -------------------------------------------------------------------------- --
 -- Properties
 
@@ -607,3 +629,4 @@ properties =
     [ ("readHostnameBytes", property prop_readHostnameBytes)
     , ("readHostAddressBytes", property prop_readHostAddressBytes)
     ]
+

src/Chainweb/RestAPI.hs

@@ -57,6 +57,7 @@ import Control.Lens
 import Data.Aeson.Encode.Pretty
 import Data.Bool (bool)
 import qualified Data.ByteString.Lazy as BL
+import Data.IxSet.Typed
 import Data.Maybe
 import Data.Proxy
 import Data.Swagger
@@ -65,8 +66,8 @@ import qualified Data.Text.Encoding as T
 
 import GHC.Generics (Generic)
 
-import Network.Socket
-import Network.Wai (Middleware, mapResponseHeaders)
+import Network.Socket (Socket)
+import Network.Wai (Middleware, mapResponseHeaders, requestHeaders, remoteHost)
 import Network.Wai.Handler.Warp hiding (Port)
 import Network.Wai.Handler.WarpTLS (TLSSettings, runTLSSocket)
 import Network.Wai.Middleware.Cors
@@ -232,6 +233,7 @@ chainwebApplication
 chainwebApplication v dbs mr hs
     = chainwebTime
     . chainwebCors
+    . chainwebValidatePeer (fromJuste $ lookup CutNetwork $ _chainwebServerPeerDbs dbs)
     . someServerApplication
     $ someChainwebServer v dbs mr hs
 
@@ -250,6 +252,30 @@ chainwebTime app req resp = app req resp'
             ((:) ("X-Server-Timestamp", sshow timestamp))
             res
 
+-- A middleware authenticating peers
+--
+-- TODO: do proper TLS client authentication
+-- TODO: add an option to trust "X-peer-info" from a proxy
+--
+chainwebValidatePeer :: PeerDb -> Middleware
+chainwebValidatePeer pdb app req resp = do
+    sn <- peerDbSnapshot pdb
+    let pinfo = case hostaddr of
+            Nothing -> Nothing
+            Just x -> _peerEntryInfo <$> getOne (getEQ x sn)
+    case pinfo of
+        Nothing -> app req resp
+        Just x -> do
+            let req' = req
+                    { requestHeaders
+                        = ("X-peer-info",  T.encodeUtf8 (toText x))
+                        : requestHeaders req
+                    }
+            app req' resp
+  where
+    sockAddr = remoteHost req
+    hostaddr = sockAddrToHostAddress sockAddr
+
 serveChainwebOnPort
     :: Show t
     => PayloadCas cas