Docker API: SSL authentication

DockerAPI.hs

{-# LANGUAGE NamedFieldPuns #-}

import Control.Monad (when)
import qualified Data.ByteString.Char8 as BSC
import Data.Default.Class (def)
import Data.Monoid ((<>))
import System.IO.Error (ioError, userError)

import Data.X509 (CertificateChain (..), HashALG(..))
import Data.X509.CertificateStore (makeCertificateStore)
import Data.X509.File (readKeyFile, readSignedObject)
import Data.X509.Validation (validate, defaultChecks, defaultHooks, ValidationHooks(..))
import System.X509 (getSystemCertificateStore)

import qualified Network.Socket as S
import Network.Connection (TLSSettings(TLSSettings))
import Network.HTTP.Client (parseRequest, httpLbs, responseStatus, responseBody,
                            Manager, newManager, defaultManagerSettings, managerRawConnection)
import Network.HTTP.Client.Internal (makeConnection)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types.Status (statusCode)
import Network.TLS (ClientHooks (..), ClientParams (..), Shared (..), Supported (..), defaultParamsClient)
import Network.TLS.Extra (ciphersuite_strong)

newSSLAuthManager :: String -> Int -> FilePath -> FilePath -> FilePath -> IO Manager
newSSLAuthManager host port privKey cert ca = do
  paramsE <- clientParamsWithClientAuth host (fromIntegral port) privKey cert
  params <- clientParamsSetCA paramsE ca
  let mSettings = mkManagerSettings (TLSSettings params) Nothing
  newManager mSettings

clientParamsWithClientAuth :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO ClientParams
clientParamsWithClientAuth host port keyFile certificateFile = do
  cert <- readSignedObject certificateFile
  keys <- readKeyFile keyFile
  when (null keys) $ ioError (userError ("Could not read key file: " ++ keyFile))
  let key = head keys
      onCertificateRequest = const . return $ Just (CertificateChain cert, key)
      onServerCertificate = validate HashSHA256 (def { hookValidateName = \_ _ -> [] }) def
      clientParams = (defaultParamsClient host $ BSC.pack (show port))
                     { clientHooks = def { onCertificateRequest, onServerCertificate }
                     , clientSupported = def { supportedCiphers = ciphersuite_strong }
                     }
  return clientParams

clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams
clientParamsSetCA params path = do
    userStore <- makeCertificateStore <$> readSignedObject path
    systemStore <- getSystemCertificateStore
    let store = userStore <> systemStore
    let oldShared = clientShared params
    return params { clientShared = oldShared { sharedCAStore = store } }

main :: IO ()
main = do
  manager <- newManager defaultManagerSettings
  manager <- newSSLAuthManager "192.168.99.100"
                               2376
                               "/Users/kseo/.docker/machine/machines/kodebox/key.pem"
                               "/Users/kseo/.docker/machine/machines/kodebox/cert.pem"
                               "/Users/kseo/.docker/machine/machines/kodebox/ca.pem"
  request <- parseRequest "https://192.168.99.100:2376/v1.25/version"
  response <- httpLbs request manager

  putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response)
  print $ responseBody response