initial commit

src/Config.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Config (
+  loadConfig,
+  Config (serve, plausible),
+  Serve (port, baseUrl, templateDir),
+  Plausible (queryUrl, token, siteId),
+) where
+
+import GHC.Generics (Generic)
+import Data.Aeson (FromJSON, eitherDecodeFileStrict)
+
+data Config = Config { serve :: !Serve, plausible :: !Plausible } deriving (Generic)
+data Serve = Serve { port :: !Int, baseUrl :: !String, templateDir :: !String } deriving (Generic)
+data Plausible = Plausible { queryUrl :: !String, token :: !String, siteId :: !String } deriving (Generic)
+
+instance FromJSON Config where
+instance FromJSON Serve where
+instance FromJSON Plausible where
+
+loadConfig :: FilePath -> IO Config
+loadConfig path = loadConfig' =<< eitherDecodeFileStrict path
+  where loadConfig' :: Either String Config -> IO Config
+        loadConfig' (Left err) = fail err
+        loadConfig' (Right config) = return config

src/Main.hs

@@ -0,0 +1,25 @@
+module Main where
+
+import Control.Concurrent (forkIO, newMVar, newEmptyMVar)
+import qualified Data.Map as Map
+import PlausibleQuery (queryPageviewsLoop)
+import Server (servePages)
+import TemplateLoader (loadTemplates)
+import TemplatePage (PageContext (PageContext, ctxPageviews))
+import System.Environment (getArgs)
+import qualified Config as C
+
+main :: IO ()
+main = do
+  (configFile:_) <- getArgs
+  config <- C.loadConfig configFile
+  let cServe = C.serve config
+
+  templates <- loadTemplates (C.baseUrl cServe) (C.templateDir cServe)
+  putStrLn $ "Found templates: " ++ show (map fst templates)
+
+  context <- newMVar $ PageContext {ctxPageviews = Map.empty}
+  updateNotify <- newEmptyMVar
+
+  _ <- forkIO $ queryPageviewsLoop config context updateNotify
+  servePages (C.port cServe) (Map.fromList templates) context updateNotify

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

src/Server.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Server (
+  servePages
+) where
+
+import Control.Applicative ((<|>))
+import Network.Wai (Application, Response, responseLBS, Request (pathInfo))
+import Network.Wai.Handler.Warp (run)
+import qualified Network.HTTP.Types as H
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Text as T
+
+import TemplatePage (PageContext, PageTemplate, buildPage)
+
+import qualified Data.ByteString as BS
+import Data.ByteString (ByteString)
+import Control.Concurrent (MVar, readMVar, tryPutMVar)
+
+app :: Map String PageTemplate -> MVar PageContext -> MVar () -> Application
+app templates context updateNotify request respond = do
+   let path = T.unpack $ T.intercalate "/" $ filter (not . T.null) $ pathInfo request
+       slashPath = if path /= "" then '/' : path else path
+       indexPath = slashPath ++ "/index.html"
+       template = Map.lookup path templates <|> Map.lookup indexPath templates
+
+   putStrLn $ "Page requested: " ++ slashPath
+   context' <- readMVar context
+
+   -- Unblock pageview cache if waiting for a request.
+   _ <- tryPutMVar updateNotify ()
+
+   respond $ respMaybe $ buildPage context' <$> template
+
+respMaybe :: Maybe ByteString -> Response
+respMaybe Nothing = notFound
+respMaybe (Just text) = responseLBS H.status200 [("content-type", "text/html")] $ BS.fromStrict text
+
+notFound :: Response
+notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "404 - File not found"
+
+servePages :: Int -> Map String PageTemplate -> MVar PageContext -> MVar () -> IO ()
+servePages port templates context updateNotify = run port $ app templates context updateNotify

src/TemplateLoader.hs

@@ -0,0 +1,16 @@
+module TemplateLoader (loadTemplates) where
+
+import Data.Bool (bool)
+import System.FilePath ((</>))
+import System.Directory (listDirectory, doesDirectoryExist)
+import qualified Data.ByteString as BS
+import TemplatePage (PageTemplate, parsePage, isUntemplated)
+
+walkFiles :: FilePath -> IO [FilePath]
+walkFiles path = foldr (mappend . forEntry . (path </>)) mempty =<< listDirectory path
+  where forEntry path' = bool (pure [path']) (walkFiles path') =<< doesDirectoryExist path'
+
+loadTemplates :: String -> FilePath -> IO [(String, PageTemplate)]
+loadTemplates baseUrl basePath = filter (not . isUntemplated . snd) <$> (mapM loadTemplate =<< walkFiles basePath)
+  where pathToUrl path = baseUrl ++ drop (length basePath) path
+        loadTemplate path = (\d -> (pathToUrl path, parsePage d)) <$> BS.readFile path

src/TemplatePage.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TemplatePage (
+  PageContext (PageContext, ctxPageviews),
+  PageTemplate,
+  parsePage,
+  buildPage,
+  isUntemplated,
+) where
+
+import GHC.Generics (Generic)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.UTF8 as BS.UTF8
+import Data.ByteString (ByteString)
+import Data.List.Split (splitOn)
+import qualified Data.Aeson as JSON
+import Data.Aeson ((.:))
+import Data.Aeson.Types (FromJSON)
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+newtype PageContext = PageContext { ctxPageviews :: Map String Int }
+
+data PageTemplatePart = PTString !ByteString | PTComputed !(PageContext -> ByteString)
+type PageTemplate = [PageTemplatePart]
+
+isUntemplated :: PageTemplate -> Bool
+isUntemplated [PTString _] = True
+isUntemplated _ = False
+
+buildPage :: PageContext -> PageTemplate -> ByteString
+buildPage context template = BS.concat $ map handlePart template
+  where handlePart (PTString p) = p
+        handlePart (PTComputed p) = p context
+
+parsePage :: ByteString -> PageTemplate
+parsePage = parseSplit . splitOn "\\\\\\\\$" . BS.UTF8.toString
+  where parseSplit :: [String] -> [PageTemplatePart]
+        parseSplit [] = []
+        parseSplit [part] = [PTString $ BS.UTF8.fromString part]
+        parseSplit (first:rest) = PTString (BS.UTF8.fromString first) : concatMap parseSegment rest
+
+        parseSegment :: String -> [PageTemplatePart]
+        parseSegment segment =
+          let (numStr, next) = break (== '$') segment
+              (templatePart, rawPart) = splitAt (read numStr) (drop 1 next)
+           in [parseTemplate $ BS.UTF8.fromString templatePart, PTString $ BS.UTF8.fromString rawPart]
+
+        parseTemplate :: ByteString -> PageTemplatePart
+        parseTemplate = parseTemplate' . JSON.decode . LBS.fromStrict
+        --parseTemplate v = PTString $ BS.UTF8.fromString $ "[-" ++ BS.UTF8.toString v ++ "-]"
+
+        parseTemplate' :: Maybe JsonTemplate -> PageTemplatePart
+        parseTemplate' Nothing = PTString "{parse error}"
+        parseTemplate' (Just jt) = PTComputed $ jsonTemplateFn jt
+
+newtype JsonTemplate = TViewCount { jtPage :: String } deriving (Generic, Show)
+
+instance FromJSON JsonTemplate where
+  parseJSON = JSON.withObject "JsonTemplate" $ \o -> o .: "t"
+    >>= \t -> case (t :: String) of
+      "pageviews" -> TViewCount <$> o .: "page"
+      other -> fail $ "Unexpected t: " ++ other
+
+jsonTemplateFn :: JsonTemplate -> (PageContext -> ByteString)
+jsonTemplateFn TViewCount { jtPage = page } PageContext { ctxPageviews = pageviews }
+  = BS.UTF8.fromString $ viewStr $ Map.lookup page pageviews
+  where viewStr Nothing = "{unk}"
+        viewStr (Just viewcount) = show viewcount