75 lines
3.2 KiB
Haskell
75 lines
3.2 KiB
Haskell
{-# 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
|