Started writing the main utilities for my webpage

14 files changed, 472 insertions, 0 deletions

diff --git a/.envrc b/.envrc
new file mode 100644
index 0000000..a5dbbcb
--- /dev/null
+++ b/.envrc
@@ -0,0 +1 @@
+use flake .
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..e5d02da
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+dist-newstyle/*
+result
+.direnv
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 0000000..1405803
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,33 @@
+{
+  description = "Main library for my webpage";
+  inputs = {
+    nixpkgs.url = "github:nixos/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+    nix-filter.url = "github:numtide/nix-filter";
+  };
+
+  outputs = { self, nixpkgs, flake-utils, nix-filter, ... }: {
+
+    overlays.default = import ./nix/overlay.nix { inherit nix-filter; };
+
+  } // flake-utils.lib.eachDefaultSystem (system: let
+      pkgs = import nixpkgs {
+        inherit system;
+        overlays = [ self.overlays.default ];
+      };
+    in {
+      packages = {
+        inherit (pkgs) site;
+        default = pkgs.site;
+      };
+
+      devShells.default = pkgs.haskellPackages.shellFor {
+        packages = p: [ p.www-main ];
+        withHoogle = true;
+        buildInputs = with pkgs.haskellPackages; [
+          cabal-install
+          hpack
+        ];
+      };
+    });
+}
diff --git a/nix/build.nix b/nix/build.nix
new file mode 100644
index 0000000..0844618
--- /dev/null
+++ b/nix/build.nix
@@ -0,0 +1,10 @@
+{ runCommand, buildAssets, ... }:
+runCommand "www-assets" {
+  nativeBuildInputs = [
+    buildAssets
+  ];
+} ''
+  mkdir -p $out/{css,logos,favicon}
+
+
+''
diff --git a/nix/overlay.nix b/nix/overlay.nix
new file mode 100644
index 0000000..c8ec384
--- /dev/null
+++ b/nix/overlay.nix
@@ -0,0 +1,24 @@
+{ nix-filter, ... }:
+final: prev: let
+  src = nix-filter {
+    root = ../.;
+    include = [
+      ../app
+      ../src
+      ../package.yaml
+      # ../www-main.cabal
+    ];
+  };
+in {
+  haskellPackages = prev.haskellPackages.extend (hfinal: hprev: {
+    www-main = hfinal.callCabal2nix "www-main" src {};
+  });
+
+  site = prev.symlinkJoin {
+    name = "site";
+    paths = [
+      (final.haskell.lib.compose.justStaticExecutables final.haksellPackages.www-main)
+      prev.rsync
+    ];
+  };
+}
diff --git a/package.yaml b/package.yaml
new file mode 100644
index 0000000..c180a88
--- /dev/null
+++ b/package.yaml
@@ -0,0 +1,68 @@
+name:     www-main
+version:  0.1.0.0
+license:  MIT
+author:   "Chris Wells"
+maintainer: "chris@mathematicaster.org"
+copyright:  "2024 Chris Wells"
+
+dependencies:
+  - base >= 4.7 && < 5
+
+language: GHC2021
+
+ghc-options:
+  - -Wall
+  - -Wcompat
+  - -Widentities
+  - -Wincomplete-record-updates
+  - -Wincomplete-uni-patterns
+  - -Wmissing-home-modules
+  - -Wpartial-fields
+  - -Wredundant-constraints
+
+default-extensions:
+  - BangPatterns
+  - DeriveGeneric
+  - DeriveLift
+  - DerivingStrategies
+  - DefaultSignatures
+  - FunctionalDependencies
+  - GADTs
+  - LambdaCase
+  - MultiWayIf
+  - OverloadedStrings
+  - PatternSynonyms
+  - TypeFamilies
+
+library:
+  source-dirs: src
+  dependencies:
+    - binary
+    - blaze-html
+    - bytestring
+    - email-validate
+    - filepath
+    - hakyll
+    - HaTeX
+    - latex-formulae-hakyll
+    - mtl
+    - network-uri
+    - pandoc
+    - parsec
+    - string-conv
+    - system
+    - text
+    - uri-encode
+
+executables:
+  site:
+    main: Main.hs
+    source-dirs: app
+    ghc-options:
+      - -threaded
+    dependencies:
+      - www-main
+      - hakyll
+      - hakyll-images
+      - hakyll-sass
+      - hjsmin
diff --git a/src/Hakyll/Core/Identifier/Pattorn.hs b/src/Hakyll/Core/Identifier/Pattorn.hs
new file mode 100644
index 0000000..0910320
--- /dev/null
+++ b/src/Hakyll/Core/Identifier/Pattorn.hs
@@ -0,0 +1,16 @@
+module Hakyll.Core.Identifier.Pattorn
+    ( Pattorn (..)
+    ) where
+
+import Prolog
+import Hakyll
+
+-- | Wrapper around 'Pattern' to get a semigroup with "or" as its operation
+newtype Pattorn = Pattorn { getPattern :: Pattern }
+    deriving newtype (Binary, Show, IsString)
+
+instance Semigroup Pattorn where
+    Pattorn a <> Pattorn b = Pattorn $ a .||. b
+
+instance Monoid Pattorn where
+    mempty = Pattorn $ complement mempty
diff --git a/src/Hakyll/TeX/BibTeX.hs b/src/Hakyll/TeX/BibTeX.hs
new file mode 100644
index 0000000..b085dfa
--- /dev/null
+++ b/src/Hakyll/TeX/BibTeX.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hakyll.TeX.BibTeX
+    ( bibtexCompiler
+    , compileBibtex
+    , BibTeX
+    ) where
+
+import Prolog
+
+import Data.List qualified as L
+import Hakyll
+import Text.BibTeX.Entry qualified as B
+import Text.BibTeX.Format qualified as B
+import Text.BibTeX.Parse qualified as B
+import Text.Parsec qualified as P
+import Text.Parsec.Error qualified as P
+
+type BibTeX = B.T
+
+deriving instance Generic B.T
+instance Binary B.T
+
+instance Writable B.T where
+    write p = write p . B.entry
+
+instance Writable [B.T] where
+    write p = write p . fold . L.intersperse "\n" . fmap B.entry
+
+
+compileBibtex :: (StringConv s String) => Item s -> Compiler (Item [B.T])
+compileBibtex (Item i b) = either (throwError . fmap P.messageString . P.errorMessages) (pure . Item i) $ P.parse p (show i) (toSL b)
+    where
+        p = B.skippingLeadingSpace $ B.file <* P.eof
+
+bibtexCompiler :: Compiler (Item [B.T])
+bibtexCompiler = getResourceBody >>= compileBibtex
diff --git a/src/Hakyll/TeX/HaTeX.hs b/src/Hakyll/TeX/HaTeX.hs
new file mode 100644
index 0000000..9b83c62
--- /dev/null
+++ b/src/Hakyll/TeX/HaTeX.hs
@@ -0,0 +1,15 @@
+module Hakyll.TeX.HaTeX
+    ( hatexCompiler
+    , compileHatex
+    ) where
+
+import Prolog
+
+import Hakyll
+import Text.LaTeX.Base.Parser
+
+compileHatex :: (StringConv s Text, Traversable t) => t s -> Compiler (t LaTeX)
+compileHatex = traverse $ either (throwError . fmap messageString . errorMessages) pure . parseLaTeX . toSL
+
+hatexCompiler :: Compiler (Item LaTeX)
+hatexCompiler = getResourceLBS >>= compileHatex
diff --git a/src/Hakyll/TeX/LaTeX.hs b/src/Hakyll/TeX/LaTeX.hs
new file mode 100644
index 0000000..8f6d5cc
--- /dev/null
+++ b/src/Hakyll/TeX/LaTeX.hs
@@ -0,0 +1,18 @@
+module Hakyll.TeX.LaTeX
+    ( latexPdfCompiler
+    , compileLatexPdf
+    , rubberPipe
+    ) where
+
+import Prolog
+
+import Hakyll
+
+rubberPipe :: [String] -> LazyByteString -> Compiler LazyByteString
+rubberPipe = unixFilterLBS "rubber-pipe"
+
+compileLatexPdf :: (StringConv s LazyByteString, Traversable t) => t s -> Compiler (t LazyByteString)
+compileLatexPdf = traverse $ rubberPipe [ "--pdf" ] . toSL
+
+latexPdfCompiler :: Compiler (Item LazyByteString)
+latexPdfCompiler = getResourceLBS >>= compileLatexPdf
diff --git a/src/Hakyll/TeX/TikZ.hs b/src/Hakyll/TeX/TikZ.hs
new file mode 100644
index 0000000..9df98fd
--- /dev/null
+++ b/src/Hakyll/TeX/TikZ.hs
@@ -0,0 +1,29 @@
+module Hakyll.TeX.TikZ
+    ( TikzTemplate
+    , tikzfilter
+    , tikzBlockFilter
+    ) where
+
+import Network.URI.Encode qualified as URI
+import Text.Pandoc.Definition
+import Text.Pandoc.Walk (walkM)
+
+import Hakyll
+
+import Prolog
+
+import Hakyll.TeX.LaTeX (rubberPipe)
+
+type TikzTemplate = Identifier
+
+tikzFilter :: TikzTemplate -> Pandoc -> Compiler Pandoc
+tikzFilter = walkM tikzBlockFilter
+
+-- | Requires `rubber` and `poppler_utils`
+tikzBlockFilter :: TikzTemplate -> Block -> Compiler Block
+tikzBlockFilter tmpl (CodeBlock info@(_, "tikzpicture":_, _) contents) = do
+    let imageBlock fname = Para [ Image info [] (toSL fname, "") ]
+    makeItem (toSL contents) >>= loadAndApplyTemplate tmpl (bodyField "body") >>=
+        traverse (convSL $ rubberPipe [ "--pdf" ] >=> unixFilterLBS "pdftocairo" [ "-svg", "-", "-" ]) >>=
+            \(Item _ b) -> imageBlock $ ("data:image/svg+sml;utf8," <>) $ URI.encode $ filter (/= '\n') b
+tikzBlockFilter _ x = pure x
diff --git a/src/Prolog.hs b/src/Prolog.hs
new file mode 100644
index 0000000..70545c9
--- /dev/null
+++ b/src/Prolog.hs
@@ -0,0 +1,166 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Prolog
+    (
+    -- * Modules
+      module Control.Applicative
+    , module Control.Monad
+    , module Control.Monad.Except
+    , module Control.Monad.Identity
+    , module Control.Monad.IO.Class
+    , module Control.Monad.Reader
+    , module Data.Bifunctor
+    , module Data.Bifoldable
+    , module Data.Bitraversable
+    , module Data.Bool
+    , module Data.Either
+    , module Data.Foldable
+    , module Data.Function
+    , module Data.Functor
+    , module Data.Functor.Contravariant
+    , module Data.Maybe
+    -- * Types
+    , Binary
+    , Generic
+    , Generically (..)
+    , MonadThrow (..)
+    , Exception (..)
+    , SomeException (..)
+    , B.StrictByteString
+    , BL.LazyByteString
+    , T.StrictText
+    , TL.LazyText
+    -- * Strings
+    , IsString (..)
+    , StringConv (..)
+    , toS
+    , toSL
+    , convS
+    , convSL
+    -- * Utils
+    , (<<$>>)
+    , (<<<$>>>)
+    , (<<&>>)
+    , (-->)
+    , (-/>)
+    , foreach
+    , liftMaybe
+    , squashMaybe
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Identity
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Data.Bifunctor
+import Data.Bifoldable
+import Data.Binary
+import Data.Bitraversable
+import Data.Bool
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as BL
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.Functor
+import Data.Functor.Contravariant
+import Data.Maybe
+import Data.String
+import Data.String.Conv
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import GHC.Generics
+
+import Hakyll qualified as H
+import Text.Blaze.Html
+import Text.Blaze.Html.Renderer.Pretty as BS
+import Text.Blaze.Html.Renderer.Text as BT
+import Text.Blaze.Html.Renderer.Utf8 as BB
+import Text.LaTeX.Base qualified as L
+
+(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
+infixl 4 <<$>>
+(<<$>>) = fmap fmap fmap
+{-# INLINE (<<$>>) #-}
+
+(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
+infixl 4 <<<$>>>
+(<<<$>>>) = fmap . fmap . fmap
+{-# INLINE (<<<$>>>) #-}
+
+(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
+infixl 1 <<&>>
+(<<&>>) = flip (<<$>>)
+{-# INLINE (<<&>>) #-}
+
+foreach :: Functor f => f a -> (a -> b) -> f b
+foreach = flip fmap
+{-# INLINE foreach #-}
+
+
+(-->) :: (Monad m, Monoid w) => m Bool -> m w -> m w
+infixr 0 -->
+b --> a = b >>= bool (pure mempty) a
+{-# INLINE (-->) #-}
+
+(-/>) :: (Monad m, Monoid w) => m Bool -> m w -> m w
+infixr 0 -/>
+(-/>) = (-->) . fmap not
+{-# INLINE (-/>) #-}
+
+liftMaybe :: Alternative m => Maybe a -> m a
+liftMaybe = maybe empty pure
+{-# INLINE liftMaybe #-}
+
+squashMaybe :: Alternative m => m (Maybe a) -> m a
+squashmaybe = (>>= liftMaybe)
+{-# INLINE squashMaybe #-}
+
+
+-- Orphan instances
+
+
+instance Binary L.MathType
+instance Binary L.Measure
+instance Binary L.TeXArg
+instance Binary L.LaTeX
+
+instance H.Writable L.LaTeX where
+    write p = L.renderFile p . H.itemBody
+
+
+instance Contravariant H.Context where
+    contramap f (H.Context c) = H.Context $ \x xs -> c x xs . fmap f
+
+
+instance StringConv L.LaTeX T.Text where
+    strConv _ = L.render
+
+instance StringConv L.LaTeX TL.Text where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX B.ByteString where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX BL.ByteString where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX String where
+    strConv l = strConv l . L.render
+
+instance StringConv Html T.Text where
+    strConv _ = BT.renderHtml
+
+instance StringConv Html TL.Text where
+    strConv l = strConv l . BT.renderHtml
+
+instance StringConv Html String where
+    strConv _ = BS.renderHtml
+
+instance StringConv Html B.ByteString where
+    strConv l = strConv l . BB.renderHtml
+
+instance StringConv Html BL.ByteString where
+    strConv _ = BB.renderHtml
diff --git a/src/WWW/Base.hs b/src/WWW/Base.hs
new file mode 100644
index 0000000..4f8d1c7
--- /dev/null
+++ b/src/WWW/Base.hs
@@ -0,0 +1,39 @@
+module WWW.Base
+    ( baseConfig
+    , baseHakyll
+    , domain
+    , wwwRoot
+    ) where
+
+import Prolog
+import Hakyll
+import System.Process
+
+
+hakyllVersion :: IsString s => s
+hakyllVersion = "Hakyll 4.16.2.2"
+
+-- | mathematicaster.org
+domain :: IsString s => s
+domain = "mathematicaster.org"
+
+-- | /var/www
+wwwRoot :: IsString s => s
+wwwRoot = "/var/www"
+
+baseConfig :: FilePath -> Configuration
+baseConfig p = defaultConfiguration
+    { destinationDirectory = "output"
+    , storeDirectory = ".cache"
+    , tmpDirectory = ".cache/tmp"
+    , deploySite = \cfg -> rawSystem "rsync"
+        [ "-aP"
+        , "--delete-after"
+        , "--chown=nginx:nginx"
+        , destinationDirectory cfg <> "/"
+        , "root@" <> domain <> ":" <> wwwRoot <> "/" <> p
+        ]
+    }
+
+baseHakyll :: MonadIO m => FilePath -> Rules a -> m ()
+baseHakyll p = liftIO . hakyllWith (baseConfig p)
diff --git a/src/WWW/HW.hs b/src/WWW/HW.hs
new file mode 100644
index 0000000..0740fe6
--- /dev/null
+++ b/src/WWW/HW.hs
@@ -0,0 +1,14 @@
+module WWW.HW
+    ( removeEnv
+    , removeSolutions
+    ) where
+
+import Prolog
+
+import Text.LaTeX.Base.Syntax
+
+removeEnv :: (String -> Bool) -> LaTeX -> LaTeX
+removeEnv p = texmap (\case { TeXEnv s _ _ -> p s; _ -> False }) $ pure mempty
+
+removeSolutions :: LaTeX -> LaTeX
+removeSolutions = removeEnv (== "solution")