Client.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module exposes functionality to create LXD clients. These can
-- be used to communciate to an LXD daemon, either using the high-level
-- "Network.LXD.Client.Commands" module, or the low-level
-- "Network.LXD.Client.API" module.
--
-- __You are probably looking for "Network.LXD.Client.Commands"__, which
-- exposes a high-level interface to communicate with the LXD daemon.
--
-- If you are simply connecting to the LXD daemon on your local host,
-- you shouldn't import this module. The "Network.LXD.Client.Commands"
-- module probably re-exports enough functionality for your needs.
--
--
module Network.LXD.Client (
  module Network.LXD.Client.Types

  -- * LXD Host Management
  -- ** HTTPS Clients
  -- *** Types
, RemoteHost(..)
, ClientAuth(..)
, ServerAuth(..)
, Host, RemoteName, Certificate, Key, PrivateKey(..)
  -- *** Functions
, remoteHostClient
, remoteHostManager
, clientManager

  -- * Unix Clients
, LocalHost(..)
, localHostClient

  -- * WebSockets Clients
, runWebSocketsRemote
, runWebSocketsLocal
) where

import Network.LXD.Client.Internal.Prelude

import Control.Exception (SomeException, tryJust, toException, throwIO, bracket)

import Data.Default (Default, def)
import Data.Either.Combinators (mapLeft)
import Data.X509 (CertificateChain)
import Data.X509.Validation (ValidationCache,
                             FailedReason(NameMismatch),
                             ServiceID,
                             validateDefault)
import Data.X509.CertificateStore (CertificateStore, readCertificateStore)
import qualified Data.ByteString.Lazy as B

import Network.LXD.Client.Types

import Network.Connection (ConnectionParams(..), TLSSettings(..), initConnectionContext)
import Network.HTTP.Client (Manager, ManagerSettings(..), newManager, defaultManagerSettings, socketConnection)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.TLS (ClientHooks(onCertificateRequest, onServerCertificate),
                    ClientParams(clientShared, clientHooks, clientSupported),
                    Credential,
                    Shared(sharedCAStore),
                    Supported(supportedCiphers),
                    credentialLoadX509,
                    defaultParamsClient)
import Network.TLS.Extra.Cipher (ciphersuite_default)
import qualified Network.Connection as Con
import qualified Network.Socket as Socket
import qualified Network.WebSockets as WS
import qualified Network.WebSockets.Stream as WS

import Servant.Client (BaseUrl(..), ClientEnv(..), Scheme(Http, Https))

import System.Directory (getHomeDirectory)
import System.IO.Error (catchIOError, isEOFError)

type RemoteName = String
type Host = String
type Certificate = FilePath
type Key = FilePath

-- | A structure containing everything to connect to a remote LXD host.
data RemoteHost = RemoteHost {
    remoteHostHost :: Host                -- ^ The remote host to use when querying the HTTP endpoint. (default=@127.0.0.1@)
  , remoteHostPort :: Int                 -- ^ The remote port to use when querying the HTTP endpoint. (default=@8443@)
  , remoteHostBasePath :: String          -- ^ The base path to use when querying the HTTP endpoint. (default=@/@)
  , remoteHostClientKey :: ClientAuth     -- ^ The client authentication to use when connecting.
  , remoteHostCertificate :: ServerAuth   -- ^ The server certificate to trust.
}

instance Default RemoteHost where
    def = RemoteHost { remoteHostHost = ""
                     , remoteHostPort = 8443
                     , remoteHostBasePath = ""
                     , remoteHostClientKey = DefaultClientAuth
                     , remoteHostCertificate = DefaultCAStore }

-- | A structure containing everything to connect to a lcoal LXD host.
newtype LocalHost = LocalHost {
    localHostUnix :: FilePath             -- ^ The path to the local unix socket.
  }

instance Default LocalHost where
    def = LocalHost { localHostUnix = "/var/lib/lxd/unix.socket" }

-- | Specifies the client authentication method.
data ClientAuth = NoClientAuth              -- ^ Do not authenticate the client.
                | DefaultClientAuth         -- ^ Look in @~/.config/lxc@ and fetch the client certificate.
                | ClientAuthKey PrivateKey   -- ^ Use a custom private key.

data PrivateKey = PrivateKey Certificate Key

privateKey :: ClientAuth -> Maybe PrivateKey
privateKey NoClientAuth        = Nothing
privateKey DefaultClientAuth   = Just (PrivateKey "~/.config/lxc/client.crt" "~/.config/lxc/client.key")
privateKey (ClientAuthKey key) = Just key

-- | Specifies the server authentication method.
data ServerAuth = DefaultCAStore                -- ^ Use the default CA store when checking the certificate.
                | DefaultServerAuth RemoteName  -- ^ Look in @~/.config/lxc/servercerts@ and fetch the server certificate for
                                                --   the specified remote.
                | ServerAuth Certificate        -- ^ Use a custom server certificate.

serverCertificate :: ServerAuth -> Maybe Certificate
serverCertificate DefaultCAStore             = Nothing
serverCertificate (DefaultServerAuth remote) = Just ("~/.config/lxc/servercerts/" ++ remote ++ ".crt")
serverCertificate (ServerAuth cert)          = Just cert

remoteHostManager :: (MonadError String m, MonadIO m) => RemoteHost -> m Manager
remoteHostManager RemoteHost{..} = clientManager remoteHostHost
                                                 (privateKey remoteHostClientKey)
                                                 (serverCertificate remoteHostCertificate)

remoteHostClient :: (MonadError String m, MonadIO m) => RemoteHost -> m ClientEnv
remoteHostClient remote@RemoteHost{..} =
    ClientEnv <$> remoteHostManager remote <*> pure baseUrl
  where
    baseUrl = BaseUrl Https remoteHostHost remoteHostPort remoteHostBasePath


clientManager :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m Manager
clientManager = ((.).(.).(.)) (>>= newManager') clientManagerSettings
  where newManager' = liftIO . newManager

clientManagerSettings :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m ManagerSettings
clientManagerSettings host clientKey serverCert = do
    tlsSettings <- clientTlsSettings host clientKey serverCert
    return $ mkManagerSettings tlsSettings Nothing

clientTlsSettings :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m TLSSettings
clientTlsSettings host clientKey serverCert =
    clientTlsSettings' host <$> credentials clientKey <*> caStore serverCert
  where
    credentials Nothing                      = return Nothing
    credentials (Just (PrivateKey cert key)) = do
        cert' <- expandHomeDirectory cert
        key'  <- expandHomeDirectory key
        creds <- liftIO . catchAdditional $ credentialLoadX509 cert' key'
        Just <$> eitherToError creds

    caStore Nothing     = return Nothing
    caStore (Just cert) = Just <$> (eitherToError =<< liftIO (readCertificateStore' cert))
    readCertificateStore' cert = maybe (Left $ "error: could not read certificate at " ++ cert) Right <$> readCertificateStore cert

clientTlsSettings' :: Host -> Maybe Credential -> Maybe CertificateStore -> TLSSettings
clientTlsSettings' host creds caStore =
    TLSSettings clientParams
  where
    hooks = def { onCertificateRequest = const $ return creds
                , onServerCertificate  = validateServerCert }
    clientParams = (defaultParamsClient host "")
                   { clientShared = shared
                   , clientHooks  = hooks
                   , clientSupported = def { supportedCiphers = ciphersuite_default }
                   }
    shared | Just store <- caStore = def { sharedCAStore = store }
           | otherwise             = def

clientConnectionParams :: (MonadError String m, MonadIO m) => RemoteHost -> m ConnectionParams
clientConnectionParams RemoteHost{..} = do
    tlsSettings <- clientTlsSettings remoteHostHost
                                     (privateKey remoteHostClientKey)
                                     (serverCertificate remoteHostCertificate)
    return ConnectionParams { connectionHostname = remoteHostHost
                            , connectionPort = fromIntegral remoteHostPort
                            , connectionUseSecure = Just tlsSettings
                            , connectionUseSocks = Nothing }

localHostClient :: MonadIO m => LocalHost -> m ClientEnv
localHostClient host = do
    m <- liftIO $ newManager defaultManagerSettings { managerRawConnection = createUnixConnection }
    return $ ClientEnv m baseUrl
  where
    createUnixConnection = return $ \_ _ _ -> do
        s <- unixSocket host
        socketConnection s 4096
    baseUrl = BaseUrl Http "localhost" 80 ""

runWebSocketsRemote :: (MonadError String m, MonadIO m) => RemoteHost -> String -> WS.ClientApp a -> m a
runWebSocketsRemote host path app = do
    ctx    <- liftIO initConnectionContext
    params <- clientConnectionParams host
    liftIO $ bracket (Con.connectTo ctx params)
                     Con.connectionClose
                     action
  where
    action con = do
        stream <- WS.makeStream (reader con) (writer con)
        WS.runClientWithStream stream
                               (remoteHostHost host)
                               path
                               WS.defaultConnectionOptions
                               []
                               app

    reader con = catchIOError (Just <$> Con.connectionGetChunk con) $ \e ->
                              if isEOFError e
                                  then return Nothing
                                  else throwIO e
    writer con bs = case bs of
        Nothing -> return ()
        Just bs' -> Con.connectionPut con (B.toStrict bs')

runWebSocketsLocal :: (MonadError String m, MonadIO m) => LocalHost -> String -> WS.ClientApp a -> m a
runWebSocketsLocal host path app = liftIO $ do
    s <- unixSocket host
    WS.runClientWithSocket s "localhost" path WS.defaultConnectionOptions [] app

validateServerCert :: CertificateStore
                   -> ValidationCache
                   -> ServiceID
                   -> CertificateChain
                   -> IO [FailedReason]
validateServerCert a b c d = filter (not . ignore) <$> validateDefault a b c d
  where ignore x | NameMismatch _ <- x = True
                 | otherwise = False

unixSocket :: LocalHost -> IO Socket.Socket
unixSocket LocalHost{..} = do
    s <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol
    Socket.connect s (Socket.SockAddrUnix localHostUnix)
    return s

catchAdditional :: IO (Either String a) -> IO (Either String a)
catchAdditional action = join . mapLeft show <$> tryJust (Just . toException') action
  where
    toException' :: SomeException -> SomeException
    toException' = toException

expandHomeDirectory :: MonadIO m => FilePath -> m FilePath
expandHomeDirectory ('~':'/':xs) = (++ "/" ++ xs) <$> liftIO getHomeDirectory
expandHomeDirectory x            = return x

eitherToError :: MonadError err m => Either err a -> m a
eitherToError (Left  x) = throwError x
eitherToError (Right x) = return x