{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingVia #-}
module HttpServer where

import Control.Monad (forever)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Data.ByteString as BS
import Data.Void (Void)
import Network.Wai.Handler.Warp (run)
import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes)
import Data.ByteString (ByteString)
import GHC.Generics (Generic)
import Servant (Handler, err404)
import Control.Monad.Catch (throwM, MonadCatch, MonadThrow)
import Servant.Server (err500, ServerT)
import Data.Maybe (fromMaybe)
import Control.Exception.Annotated (checkpoint, Annotation (Annotation))
import Servant.Server.Generic (genericServeT)
import Network.Wai (Application)
import Network.HTTP.Media ((//))
import HomeAssistant.Runtime.Graphing (Graph, Range (..), lookupGraph, graphs, renderGraph)
import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM)

data ImagePng

instance MimeRender ImagePng ByteString where
  mimeRender _ = BS.fromStrict

instance Accept ImagePng where
  contentType _ = "image" // "png"


newtype API mode = API
  { getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] ByteString
  }
  deriving Generic


getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler ByteString
getMetricsHandler rrdPath rrdtool graphMode mRange = checkpoint (Annotation (graphMode, mRange)) $ do
  case lookupGraph graphs graphMode of
    Nothing -> throwM err404
    Just spec -> do
      let range = fromMaybe OneDay mRange
      g <- renderGraph rrdPath rrdtool spec range
      either (\e -> logFM ErrorS (ls e) >> throwM err500) pure g

-- server :: FilePath -> FilePath -> API AsServer
server :: FilePath -> FilePath -> ServerT (NamedRoutes API) LoggingHandler
server rrdPath rrdtool = API { getMetrics = getMetricsHandler rrdPath rrdtool }

servantApp :: LogEnv -> FilePath -> FilePath -> Application
servantApp le rrdPath rrdtool = genericServeT (toHandler le) (server rrdPath rrdtool)

runHttpServer :: MonadIO m => LogEnv -> FilePath -> FilePath -> Int -> m Void
runHttpServer le rrdPath rrdtool port = liftIO $ forever $ run port (servantApp le rrdPath rrdtool)

newtype LoggingHandler a = LoggingHandler (KatipContextT Handler a)
  deriving (Functor, Applicative, Monad, MonadIO, Katip, KatipContext, MonadCatch, MonadThrow) via (KatipContextT Handler)

toHandler :: LogEnv -> (forall a.  LoggingHandler a -> Handler a)
toHandler le (LoggingHandler k) = runKatipContextT le () "http" k