TypedWatch

TypedWatch.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
module TypedWatch where

import Control.Exception.Safe
import Data.Aeson
import Data.Function           ((&))
import Data.Text               (Text)
import Kubernetes.Client.Watch
import Kubernetes.OpenAPI
import Network.HTTP.Client     (Manager)
import Streaming.Prelude       (Of, Stream)
import Kubernetes.OpenAPI.API.CoreV1

import qualified Data.ByteString.Streaming.Char8 as Q
import qualified Data.Text.IO                    as T
import qualified Streaming.Prelude               as S
import qualified Data.Map as Map

-- | Parse the stream using the given parser.
streamParse ::
  FromJSON a => Q.ByteString IO r -> Stream (Of (Either String a)) IO r
streamParse byteStream = do
  decodeJSON $ Q.lines $ byteStream

-- | Parse a single event from the stream.
decodeJSON ::
  (FromJSON a, Monad m) =>
  Stream (Q.ByteString m) m r -> Stream (Of (Either String a)) m r
decodeJSON byteStream = S.map eitherDecode (S.mapped Q.toLazy byteStream)

dispatchTypedWatch ::
  (HasOptionalParam req Watch, MimeType accept, MimeType contentType,
   FromJSON a) =>
  Manager
  -> KubernetesClientConfig
  -> KubernetesRequest req contentType resp accept
  -> (Stream (Of (Either String (WatchEvent a))) IO () -> IO ())
  -> IO ()
dispatchTypedWatch mgr cfg req f = do
  let withResponseBody body = streamParse body & f
  dispatchWatch mgr cfg req (withResponseBody)

-- Example usage

printPodEvent :: Either String (WatchEvent V1Pod) -> IO ()
printPodEvent (Right w) = T.putStrLn $ eventType w <> " -> " <> podName (eventObject w)
printPodEvent (Left e) = error e

podName :: V1Pod -> Text
podName pod = case v1PodMetadata pod >>= v1ObjectMetaName of
                Nothing -> "unnamed-pod"
                Just n  -> n

program :: Manager -> KubernetesClientConfig -> IO ()
program mgr cfg = do
  let listFn = listNamespacedPod (Accept MimeJSON) (Namespace "default")
  dispatchTypedWatch mgr cfg listFn (S.mapM_ printPodEvent)