initial commit

src/PlausibleQuery.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module PlausibleQuery (queryPageviewsLoop) where
+
+import GHC.Generics (Generic)
+import Data.Map (Map)
+import qualified Data.ByteString.UTF8 as BS.UTF8
+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 (removeTrailingSlash path, count)
+        parseResult result = Left $ "Could not parse result: " ++ show result
+
+        removeTrailingSlash "" = ""
+        removeTrailingSlash "/" = ""
+        removeTrailingSlash (x:xs) = x : removeTrailingSlash xs
+
+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.UTF8.fromString $ "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