{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module PlausibleQuery (queryPageviewsLoop) where

import GHC.Generics (Generic)
import Data.Map (Map)
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.Map as Map
import qualified Data.Aeson as JSON
import Data.Aeson (FromJSON, (.=))
import qualified Network.HTTP.Simple as H
import qualified Network.HTTP.Types.Header as H
import Control.Concurrent (MVar, threadDelay, putMVar)
import Control.Concurrent.MVar (takeMVar)
import Control.Exception (Exception (displayException), catch, SomeException)

import TemplatePage (PageContext (ctxPageviews))
import qualified Config as C

newtype MetricsResponse = MetricsResponse { results :: [MRResult] } deriving (Generic, Show)
data MRResult = MRResult { metrics :: [Int], dimensions :: [String] } deriving (Generic, Show)

instance FromJSON MetricsResponse where
instance FromJSON MRResult where

parseMetricsResponse :: MetricsResponse -> Either String (Map String Int)
parseMetricsResponse MetricsResponse { results = r } = Map.fromList <$> mapM parseResult r
  where parseResult :: MRResult -> Either String (String, Int)
        parseResult MRResult { metrics = [count], dimensions = [path] } = Right (path, count)
        parseResult result = Left $ "Could not parse result: " ++ show result

queryPageviews :: C.Config -> IO (Either String (Map String Int))
queryPageviews config = do
  request' <- H.parseRequest $ "POST " ++ C.queryUrl (C.plausible config)
  let request
        = H.addRequestHeader H.hAuthorization (BS.Char8.pack $ "Bearer " ++ C.token (C.plausible config))
        $ H.setRequestBodyJSON
            (JSON.object [
              "site_id" .= C.siteId (C.plausible config),
              "metrics" .= ["visitors" :: JSON.Value],
              "dimensions" .= ["event:page" :: JSON.Value],
              "filters" .= [[
                "matches" :: JSON.Value,
                "event:page" :: JSON.Value,
                JSON.toJSON ['^' : C.baseUrl (C.serve config) ++ "/.*$"]
              ]],
              "date_range" .= ("all" :: JSON.Value)
            ])
        $ request'

  response <- H.httpJSON request
  return $ parseMetricsResponse $ H.getResponseBody response

queryPageviewsLoop :: C.Config -> MVar PageContext -> MVar () -> IO ()
queryPageviewsLoop config context updateNotify = loop
  where loop = do
          putStrLn "Querying pageviews from analytics..."
          pageviewResult <- queryPageviews config `catch` \e -> return $ Left $ displayException (e :: SomeException)
          case pageviewResult of
            Left e -> do
              putStrLn $ "Failed to query pageviews: " ++ e ++ "\nRetrying in 10 seconds."
              threadDelay $ 10 * 1000000
              loop
            Right pageviews -> do
              context' <- takeMVar context
              let context'' = context' { ctxPageviews = pageviews }
              putMVar context context''
              putStrLn $ "Updated pageview cache: " ++ show (Map.toList pageviews)

              threadDelay $ 20 * 1000000
              -- Don't make another query until a page is queried, as the stats shouldn't change without a pageview.
              takeMVar updateNotify

              loop