initial commit

.gitignore

@@ -0,0 +1,8 @@
+*
+!/.gitignore
+
+!/*.cabal
+!/src
+!/src/**
+
+!/*.nix

blog-proxy.cabal

@@ -0,0 +1,30 @@
+cabal-version: 3.0
+name: blog-proxy
+version: 0.1.0.0
+author: outfoxxed
+build-type: Simple
+
+common warnings
+  ghc-options: -Wall
+
+executable blog-proxy
+  import: warnings
+  main-is: Main.hs
+  other-modules: Config, TemplatePage, TemplateLoader, PlausibleQuery, Server
+  hs-source-dirs: src
+  default-language: Haskell2010
+
+  build-depends:
+    base ^>= 4.18.2.0,
+    bytestring ^>= 0.11.5.0,
+    utf8-string ^>= 1.0.0,
+    text ^>= 2.0.0,
+    split ^>= 0.2.5,
+    containers ^>= 0.6.7,
+    filepath ^>= 1.4.300.0,
+    directory ^>= 1.3.8.0,
+    aeson ^>= 2.1.2.0,
+    http-types ^>= 0.12.4,
+    http-conduit ^>= 2.3.9.0,
+    wai ^>= 3.2.4,
+    warp ^>= 3.3.31,

default.nix

@@ -0,0 +1,5 @@
+{
+  nix-gitignore,
+  haskell,
+  haskellPackages,
+}: haskellPackages.callCabal2nix "blog-proxy" (nix-gitignore.gitignoreSource [] ./.) {}

flake.nix

@@ -0,0 +1,23 @@
+{
+  inputs = {
+    nixpkgs.url = "nixpkgs/nixos-unstable";
+  };
+
+  outputs = { self, nixpkgs }: let
+    forEachSystem = fn: nixpkgs.lib.genAttrs
+      [ "x86_64-linux" "aarch64-linux" ]
+      (system: fn system nixpkgs.legacyPackages.${system});
+  in {
+    packages = forEachSystem (system: pkgs: rec {
+      blog-proxy = pkgs.callPackage ./default.nix {};
+      default = blog-proxy;
+    });
+
+    devShells = forEachSystem (system: pkgs: rec {
+      default = import ./shell.nix {
+        inherit pkgs;
+        inherit (self.packages.${system}) blog-proxy;
+      };
+    });
+  };
+}

shell.nix

@@ -0,0 +1,7 @@
+{
+  pkgs ? import <nixpkgs> {},
+  blog-proxy ? pkgs.callPackage ./default.nix {},
+}: pkgs.haskellPackages.shellFor {
+  packages = _: [ blog-proxy ];
+  buildInputs = [ pkgs.haskellPackages.cabal-install ];
+}

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